/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import logic.is_empty
import control.traversable.basic
import tactic.basic

/-!
# Option of a type

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

This file develops the basic theory of option types.

If `α` is a type, then `option α` can be understood as the type with one more element than `α`.
`option α` has terms `some a`, where `a : α`, and `none`, which is the added element.
This is useful in multiple ways:
* It is the prototype of addition of terms to a type. See for example `with_bot α` which uses
  `none` as an element smaller than all others.
* It can be used to define failsafe partial functions, which return `some the_result_we_expect`
  if we can find `the_result_we_expect`, and `none` if there is no meaningful result. This forces
  any subsequent use of the partial function to explicitly deal with the exceptions that make it
  return `none`.
* `option` is a monad. We love monads.

`part` is an alternative to `option` that can be seen as the type of `true`/`false` values
along with a term `a : α` if the value is `true`.

## Implementation notes

`option` is currently defined in core Lean, but this will change in Lean 4.
-/

namespace option
variables {α β γ δ : Type*}

lemma coe_def : (coe : α → option α) = some := rfl
lemma some_eq_coe (a : α) : some a = a := rfl

lemma some_ne_none (x : α) : some x ≠ none := λ h, option.no_confusion h
@[simp] lemma coe_ne_none (a : α) : (a : option α) ≠ none .

protected lemma «forall» {p : option α → Prop} : (∀ x, p x) ↔ p none ∧ ∀ x, p (some x) :=
⟨λ h, ⟨h _, λ x, h _⟩, λ h x, option.cases_on x h.1 h.2⟩

protected lemma «exists» {p : option α → Prop} : (∃ x, p x) ↔ p none ∨ ∃ x, p (some x) :=
⟨λ ⟨x, hx⟩, (option.cases_on x or.inl $ λ x hx, or.inr ⟨x, hx⟩) hx,
  λ h, h.elim (λ h, ⟨_, h⟩) (λ ⟨x, hx⟩, ⟨_, hx⟩)⟩

@[simp] theorem get_mem : ∀ {o : option α} (h : is_some o), option.get h ∈ o
| (some a) _ := rfl

theorem get_of_mem {a : α} : ∀ {o : option α} (h : is_some o), a ∈ o → option.get h = a
| _ _ rfl := rfl

@[simp] lemma not_mem_none (a : α) : a ∉ (none : option α) :=
λ h, option.no_confusion h

@[simp] lemma some_get : ∀ {x : option α} (h : is_some x), some (option.get h) = x
| (some x) hx := rfl

@[simp] lemma get_some (x : α) (h : is_some (some x)) : option.get h = x := rfl

@[simp] lemma get_or_else_some (x y : α) : option.get_or_else (some x) y = x := rfl

@[simp] lemma get_or_else_none (x : α) : option.get_or_else none x = x := rfl

@[simp] lemma get_or_else_coe (x y : α) : option.get_or_else ↑x y = x := rfl

lemma get_or_else_of_ne_none {x : option α} (hx : x ≠ none) (y : α) : some (x.get_or_else y) = x :=
by cases x; [contradiction, rw get_or_else_some]

@[simp] lemma coe_get {o : option α} (h : o.is_some) : ((option.get h : α) : option α) = o :=
option.some_get h

theorem mem_unique {o : option α} {a b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
option.some.inj $ ha.symm.trans hb

theorem eq_of_mem_of_mem {a : α} {o1 o2 : option α} (h1 : a ∈ o1) (h2 : a ∈ o2) : o1 = o2 :=
h1.trans h2.symm

theorem mem.left_unique : relator.left_unique ((∈) : α → option α → Prop) :=
λ a o b, mem_unique

theorem some_injective (α : Type*) : function.injective (@some α) :=
λ _ _, some_inj.mp

/-- `option.map f` is injective if `f` is injective. -/
theorem map_injective {f : α → β} (Hf : function.injective f) : function.injective (option.map f)
| none      none      H := rfl
| (some a₁) (some a₂) H := by rw Hf (option.some.inj H)

@[simp] theorem map_comp_some (f : α → β) : option.map f ∘ some = some ∘ f := rfl

@[ext] theorem ext : ∀ {o₁ o₂ : option α}, (∀ a, a ∈ o₁ ↔ a ∈ o₂) → o₁ = o₂
| none     none     H := rfl
| (some a) o        H := ((H _).1 rfl).symm
| o        (some b) H := (H _).2 rfl

theorem eq_none_iff_forall_not_mem {o : option α} :
  o = none ↔ (∀ a, a ∉ o) :=
⟨λ e a h, by rw e at h; cases h, λ h, ext $ by simpa⟩

@[simp] theorem none_bind {α β} (f : α → option β) : none >>= f = none := rfl

@[simp] theorem some_bind {α β} (a : α) (f : α → option β) : some a >>= f = f a := rfl

@[simp] theorem none_bind' (f : α → option β) : none.bind f = none := rfl

@[simp] theorem some_bind' (a : α) (f : α → option β) : (some a).bind f = f a := rfl

@[simp] theorem bind_some : ∀ x : option α, x >>= some = x :=
@bind_pure α option _ _

@[simp] theorem bind_some' : ∀ x : option α, x.bind some = x :=
bind_some

@[simp] theorem bind_eq_some {α β} {x : option α} {f : α → option β} {b : β} :
  x >>= f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_some' {x : option α} {f : α → option β} {b : β} :
  x.bind f = some b ↔ ∃ a, x = some a ∧ f a = some b :=
by cases x; simp

@[simp] theorem bind_eq_none' {o : option α} {f : α → option β} :
  o.bind f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
by simp only [eq_none_iff_forall_not_mem, not_exists, not_and, mem_def, bind_eq_some']

@[simp] theorem bind_eq_none {α β} {o : option α} {f : α → option β} :
  o >>= f = none ↔ (∀ b a, a ∈ o → b ∉ f a) :=
bind_eq_none'

lemma bind_comm {α β γ} {f : α → β → option γ} (a : option α) (b : option β) :
  a.bind (λx, b.bind (f x)) = b.bind (λy, a.bind (λx, f x y)) :=
by cases a; cases b; refl

lemma bind_assoc (x : option α) (f : α → option β) (g : β → option γ) :
  (x.bind f).bind g = x.bind (λ y, (f y).bind g) := by cases x; refl

lemma join_eq_some {x : option (option α)} {a : α} : x.join = some a ↔ x = some (some a) := by simp

lemma join_ne_none {x : option (option α)} : x.join ≠ none ↔ ∃ z, x = some (some z) := by simp

lemma join_ne_none' {x : option (option α)} : ¬(x.join = none) ↔ ∃ z, x = some (some z) := by simp

lemma join_eq_none {o : option (option α)} : o.join = none ↔ o = none ∨ o = some none :=
by rcases o with _|_|_; simp

lemma bind_id_eq_join {x : option (option α)} : x >>= id = x.join := by simp

lemma join_eq_join : mjoin = @join α :=
funext (λ x, by rw [mjoin, bind_id_eq_join])

lemma bind_eq_bind {α β : Type*} {f : α → option β} {x : option α} :
  x >>= f = x.bind f := rfl

@[simp] lemma map_eq_map {α β} {f : α → β} :
  (<$>) f = option.map f := rfl

theorem map_none {α β} {f : α → β} : f <$> none = none := rfl

theorem map_some {α β} {a : α} {f : α → β} : f <$> some a = some (f a) := rfl

theorem map_coe {α β} {a : α} {f : α → β} : f <$> (a : option α) = ↑(f a) := rfl

@[simp] theorem map_none' {f : α → β} : option.map f none = none := rfl

@[simp] theorem map_some' {a : α} {f : α → β} : option.map f (some a) = some (f a) := rfl

@[simp] theorem map_coe' {a : α} {f : α → β} : option.map f (a : option α) = ↑(f a) := rfl

theorem map_eq_some {α β} {x : option α} {f : α → β} {b : β} :
  f <$> x = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

@[simp] theorem map_eq_some' {x : option α} {f : α → β} {b : β} :
  x.map f = some b ↔ ∃ a, x = some a ∧ f a = b :=
by cases x; simp

lemma map_eq_none {α β} {x : option α} {f : α → β} :
  f <$> x = none ↔ x = none :=
by { cases x; simp only [map_none, map_some, eq_self_iff_true] }

@[simp] lemma map_eq_none' {x : option α} {f : α → β} :
  x.map f = none ↔ x = none :=
by { cases x; simp only [map_none', map_some', eq_self_iff_true] }

/-- `option.map` as a function between functions is injective. -/
theorem map_injective' : function.injective (@option.map α β) :=
λ f g h, funext $ λ x, some_injective _ $ by simp only [← map_some', h]

@[simp] theorem map_inj {f g : α → β} : option.map f = option.map g ↔ f = g :=
map_injective'.eq_iff

lemma map_congr {f g : α → β} {x : option α} (h : ∀ a ∈ x, f a = g a) :
  option.map f x = option.map g x :=
by { cases x; simp only [map_none', map_some', h, mem_def] }

attribute [simp] map_id

@[simp] theorem map_eq_id {f : α → α} : option.map f = id ↔ f = id := map_injective'.eq_iff' map_id

@[simp] lemma map_map (h : β → γ) (g : α → β) (x : option α) :
  option.map h (option.map g x) = option.map (h ∘ g) x :=
by { cases x; simp only [map_none', map_some'] }

lemma map_comm {f₁ : α → β} {f₂ : α → γ} {g₁ : β → δ} {g₂ : γ → δ} (h : g₁ ∘ f₁ = g₂ ∘ f₂) (a : α) :
  (option.map f₁ a).map g₁ = (option.map f₂ a).map g₂ :=
by rw [map_map, h, ←map_map]

lemma comp_map (h : β → γ) (g : α → β) (x : option α) :
  option.map (h ∘ g) x = option.map h (option.map g x) := (map_map _ _ _).symm

@[simp] lemma map_comp_map (f : α → β) (g : β → γ) :
  option.map g ∘ option.map f = option.map (g ∘ f) :=
by { ext x, rw comp_map }

lemma mem_map_of_mem {a : α} {x : option α} (g : α → β) (h : a ∈ x) : g a ∈ x.map g :=
mem_def.mpr ((mem_def.mp h).symm ▸ map_some')

lemma mem_map {f : α → β} {y : β} {o : option α} : y ∈ o.map f ↔ ∃ x ∈ o, f x = y := by simp

lemma forall_mem_map {f : α → β} {o : option α} {p : β → Prop} :
  (∀ y ∈ o.map f, p y) ↔ ∀ x ∈ o, p (f x) :=
by simp

lemma exists_mem_map {f : α → β} {o : option α} {p : β → Prop} :
  (∃ y ∈ o.map f, p y) ↔ ∃ x ∈ o, p (f x) :=
by simp

lemma bind_map_comm {α β} {x : option (option α) } {f : α → β} :
  x >>= option.map f = x.map (option.map f) >>= id :=
by { cases x; simp }

lemma join_map_eq_map_join {f : α → β} {x : option (option α)} :
  (x.map (option.map f)).join = x.join.map f :=
by { rcases x with _ | _ | x; simp }

lemma join_join {x : option (option (option α))} :
  x.join.join = (x.map join).join :=
by { rcases x with _ | _ | _ | x; simp }

lemma mem_of_mem_join {a : α} {x : option (option α)} (h : a ∈ x.join) : some a ∈ x :=
mem_def.mpr ((mem_def.mp h).symm ▸ join_eq_some.mp h)

section pmap

variables {p : α → Prop} (f : Π (a : α), p a → β) (x : option α)

@[simp] lemma pbind_eq_bind (f : α → option β) (x : option α) :
  x.pbind (λ a _, f a) = x.bind f :=
by { cases x; simp only [pbind, none_bind', some_bind'] }

lemma map_bind {α β γ} (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x >>= g) = (x >>= λ a, option.map f (g a)) :=
by simp_rw [←map_eq_map, ←bind_pure_comp_eq_map,is_lawful_monad.bind_assoc]

lemma map_bind' (f : β → γ) (x : option α) (g : α → option β) :
  option.map f (x.bind g) = x.bind (λ a, option.map f (g a)) :=
by { cases x; simp }

lemma map_pbind (f : β → γ) (x : option α) (g : Π a, a ∈ x → option β) :
  option.map f (x.pbind g) = (x.pbind (λ a H, option.map f (g a H))) :=
by { cases x; simp only [pbind, map_none'] }

lemma pbind_map (f : α → β) (x : option α) (g : Π (b : β), b ∈ x.map f → option γ) :
  pbind (option.map f x) g = x.pbind (λ a h, g (f a) (mem_map_of_mem _ h)) :=
by { cases x; refl }

@[simp] lemma pmap_none (f : Π (a : α), p a → β) {H} : pmap f (@none α) H = none := rfl

@[simp] lemma pmap_some (f : Π (a : α), p a → β) {x : α} (h : p x) :
  pmap f (some x) = λ _, some (f x h) := rfl

lemma mem_pmem {a : α} (h : ∀ a ∈ x, p a) (ha : a ∈ x) :
  f a (h a ha) ∈ pmap f x h :=
by { rw mem_def at ha ⊢, subst ha, refl }

lemma pmap_map (g : γ → α) (x : option γ) (H) :
  pmap f (x.map g) H = pmap (λ a h, f (g a) h) x (λ a h, H _ (mem_map_of_mem _ h)) :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma map_pmap (g : β → γ) (f : Π a, p a → β) (x H) :
  option.map g (pmap f x H) = pmap (λ a h, g (f a h)) x H :=
by { cases x; simp only [map_none', map_some', pmap] }

@[simp] lemma pmap_eq_map (p : α → Prop) (f : α → β) (x H) :
  @pmap _ _ p (λ a _, f a) x H = option.map f x :=
by { cases x; simp only [map_none', map_some', pmap] }

lemma bind_pmap {α β γ} {p : α → Prop} (f : Π a, p a → β) (x : option α) (g : β → option γ) (H) :
  (pmap f x H) >>= g = x.pbind (λ a h, g (f a (H _ h))) :=
by { cases x; simp only [pmap, none_bind, some_bind, pbind] }

variables {f x}

lemma pbind_eq_none {f : Π (a : α), a ∈ x → option β}
  (h' : ∀ a ∈ x, f a H = none → x = none) :
  x.pbind f = none ↔ x = none :=
begin
  cases x,
  { simp },
  { simp only [pbind, iff_false],
    intro h,
    cases h' x rfl h }
end

lemma pbind_eq_some {f : Π (a : α), a ∈ x → option β} {y : β} :
  x.pbind f = some y ↔ ∃ (z ∈ x), f z H = some y :=
begin
  cases x,
  { simp },
  { simp only [pbind],
    split,
    { intro h,
      use x,
      simpa only [mem_def, exists_prop_of_true] using h },
    { rintro ⟨z, H, hz⟩,
      simp only [mem_def] at H,
      simpa only [H] using hz } }
end

@[simp] lemma pmap_eq_none_iff {h} :
  pmap f x h = none ↔ x = none :=
by { cases x; simp }

@[simp] lemma pmap_eq_some_iff {hf} {y : β} :
  pmap f x hf = some y ↔ ∃ (a : α) (H : x = some a), f a (hf a H) = y :=
begin
  cases x,
  { simp only [not_mem_none, exists_false, pmap, not_false_iff, exists_prop_of_false] },
  { split,
    { intro h,
      simp only [pmap] at h,
      exact ⟨x, rfl, h⟩ },
    { rintro ⟨a, H, rfl⟩,
      simp only [mem_def] at H,
      simp only [H, pmap] } }
end

@[simp] lemma join_pmap_eq_pmap_join {f : Π a, p a → β} {x : option (option α)} (H) :
  (pmap (pmap f) x H).join = pmap f x.join (λ a h, H (some a) (mem_of_mem_join h) _ rfl) :=
by { rcases x with _ | _ | x; simp }

end pmap

@[simp] theorem seq_some {α β} {a : α} {f : α → β} : some f <*> some a = some (f a) := rfl

@[simp] theorem some_orelse' (a : α) (x : option α) : (some a).orelse x = some a := rfl

@[simp] theorem some_orelse (a : α) (x : option α) : (some a <|> x) = some a := rfl

@[simp] theorem none_orelse' (x : option α) : none.orelse x = x :=
by cases x; refl

@[simp] theorem none_orelse (x : option α) : (none <|> x) = x := none_orelse' x

@[simp] theorem orelse_none' (x : option α) : x.orelse none = x :=
by cases x; refl

@[simp] theorem orelse_none (x : option α) : (x <|> none) = x := orelse_none' x

@[simp] theorem is_some_none : @is_some α none = ff := rfl

@[simp] theorem is_some_some {a : α} : is_some (some a) = tt := rfl

theorem is_some_iff_exists {x : option α} : is_some x ↔ ∃ a, x = some a :=
by cases x; simp [is_some]; exact ⟨_, rfl⟩

@[simp] theorem is_none_none : @is_none α none = tt := rfl

@[simp] theorem is_none_some {a : α} : is_none (some a) = ff := rfl

@[simp] theorem not_is_some {a : option α} : is_some a = ff ↔ a.is_none = tt :=
by cases a; simp

lemma eq_some_iff_get_eq {o : option α} {a : α} :
  o = some a ↔ ∃ h : o.is_some, option.get h = a :=
by cases o; simp

lemma not_is_some_iff_eq_none {o : option α} :  ¬o.is_some ↔ o = none :=
by cases o; simp

lemma ne_none_iff_is_some {o : option α} : o ≠ none ↔ o.is_some :=
by cases o; simp

lemma ne_none_iff_exists {o : option α} : o ≠ none ↔ ∃ (x : α), some x = o :=
by {cases o; simp}

lemma ne_none_iff_exists' {o : option α} : o ≠ none ↔ ∃ (x : α), o = some x :=
ne_none_iff_exists.trans $ exists_congr $ λ _, eq_comm

lemma bex_ne_none {p : option α → Prop} :
  (∃ x ≠ none, p x) ↔ ∃ x, p (some x) :=
⟨λ ⟨x, hx, hp⟩, ⟨get $ ne_none_iff_is_some.1 hx, by rwa [some_get]⟩,
  λ ⟨x, hx⟩, ⟨some x, some_ne_none x, hx⟩⟩

lemma ball_ne_none {p : option α → Prop} :
  (∀ x ≠ none, p x) ↔ ∀ x, p (some x) :=
⟨λ h x, h (some x) (some_ne_none x),
  λ h x hx, by simpa only [some_get] using h (get $ ne_none_iff_is_some.1 hx)⟩

theorem iget_mem [inhabited α] : ∀ {o : option α}, is_some o → o.iget ∈ o
| (some a) _ := rfl

theorem iget_of_mem [inhabited α] {a : α} : ∀ {o : option α}, a ∈ o → o.iget = a
| _ rfl := rfl

lemma get_or_else_default_eq_iget [inhabited α] (o : option α) : o.get_or_else default = o.iget :=
by cases o; refl

@[simp] theorem guard_eq_some {p : α → Prop} [decidable_pred p] {a b : α} :
  guard p a = some b ↔ a = b ∧ p a :=
by by_cases p a; simp [option.guard, h]; intro; contradiction

@[simp] theorem guard_eq_some' {p : Prop} [decidable p] (u) : _root_.guard p = some u ↔ p :=
begin
  cases u,
  by_cases p; simp [_root_.guard, h]; refl <|> contradiction,
end

theorem lift_or_get_choice {f : α → α → α} (h : ∀ a b, f a b = a ∨ f a b = b) :
  ∀ o₁ o₂, lift_or_get f o₁ o₂ = o₁ ∨ lift_or_get f o₁ o₂ = o₂
| none     none     := or.inl rfl
| (some a) none     := or.inl rfl
| none     (some b) := or.inr rfl
| (some a) (some b) := by simpa [lift_or_get] using h a b

@[simp] lemma lift_or_get_none_left {f} {b : option α} : lift_or_get f none b = b :=
by cases b; refl

@[simp] lemma lift_or_get_none_right {f} {a : option α} : lift_or_get f a none = a :=
by cases a; refl

@[simp] lemma lift_or_get_some_some {f} {a b : α} :
  lift_or_get f (some a) (some b) = f a b := rfl

/-- Given an element of `a : option α`, a default element `b : β` and a function `α → β`, apply this
function to `a` if it comes from `α`, and return `b` otherwise. -/
def cases_on' : option α → β → (α → β) → β
| none     n s := n
| (some a) n s := s a

@[simp] lemma cases_on'_none (x : β) (f : α → β) : cases_on' none x f = x := rfl

@[simp] lemma cases_on'_some (x : β) (f : α → β) (a : α) : cases_on' (some a) x f = f a := rfl

@[simp] lemma cases_on'_coe (x : β) (f : α → β) (a : α) : cases_on' (a : option α) x f = f a := rfl

@[simp] lemma cases_on'_none_coe (f : option α → β) (o : option α) :
  cases_on' o (f none) (f ∘ coe) = f o :=
by cases o; refl

@[simp] lemma get_or_else_map (f : α → β) (x : α) (o : option α) :
  get_or_else (o.map f) (f x) = f (get_or_else o x) :=
by cases o; refl

lemma orelse_eq_some (o o' : option α) (x : α) :
  (o <|> o') = some x ↔ o = some x ∨ (o = none ∧ o' = some x) :=
begin
  cases o,
  { simp only [true_and, false_or, eq_self_iff_true, none_orelse] },
  { simp only [some_orelse, or_false, false_and] }
end

lemma orelse_eq_some' (o o' : option α) (x : α) :
  o.orelse o' = some x ↔ o = some x ∨ (o = none ∧ o' = some x) :=
option.orelse_eq_some o o' x

@[simp] lemma orelse_eq_none (o o' : option α) :
  (o <|> o') = none ↔ (o = none ∧ o' = none) :=
begin
  cases o,
  { simp only [true_and, none_orelse, eq_self_iff_true] },
  { simp only [some_orelse, false_and], }
end

@[simp] lemma orelse_eq_none' (o o' : option α) :
  o.orelse o' = none ↔ (o = none ∧ o' = none) :=
option.orelse_eq_none o o'

section
open_locale classical

/-- An arbitrary `some a` with `a : α` if `α` is nonempty, and otherwise `none`. -/
noncomputable def choice (α : Type*) : option α :=
if h : nonempty α then
  some h.some
else
  none

lemma choice_eq {α : Type*} [subsingleton α] (a : α) : choice α = some a :=
begin
  dsimp [choice],
  rw dif_pos (⟨a⟩ : nonempty α),
  congr,
end

lemma choice_eq_none (α : Type*) [is_empty α] : choice α = none :=
dif_neg (not_nonempty_iff_imp_false.mpr is_empty_elim)

lemma choice_is_some_iff_nonempty {α : Type*} : (choice α).is_some ↔ nonempty α :=
begin
  fsplit,
  { intro h, exact ⟨option.get h⟩, },
  { intro h,
    dsimp only [choice],
    rw dif_pos h,
    exact is_some_some },
end

end

@[simp] lemma to_list_some (a : α) : (a : option α).to_list = [a] :=
rfl

@[simp] lemma to_list_none (α : Type*) : (none : option α).to_list = [] :=
rfl

@[simp] lemma elim_none_some (f : option α → β) : option.elim (f none) (f ∘ some) = f :=
funext $ λ o, by cases o; refl

end option


import tactic
import .tokens
import .commun

namespace tactic
setup_tactic_parser

@[derive has_reflect]
meta inductive Supposons_args
| regular : list pexpr → Supposons_args
| absurde : name → option pexpr → Supposons_args

meta def Supposons_parser : lean.parser Supposons_args :=
with_desc "... / Supposons par l'absurde ..." $
do { _ ← tk "par", _ ← tk "l'absurde",
     n ← ident,
     do { _ ← tk ":",
          hyp ← texpr,
          pure (Supposons_args.absurde n (some hyp)) } <|>
     pure (Supposons_args.absurde n none)} <|>
Supposons_args.regular <$> ((tk "que")? *>parse_binders tac_rbp)

private meta def supposons_core (n : name) (ty : pexpr) :=
do verifie_nom n,
   t ← target,
   when (not $ t.is_pi) whnf_target,
   t ← target,
   when (not $ t.is_arrow) $
     fail "Il n'y a rien à supposer ici, le but n'est pas une implication",
   ty ← i_to_expr ty,
   unify ty t.binding_domain,
   intro_core n >> skip

open Supposons_args

/-- Introduit une hypothèse quand le but est une implication,
ou bien démarre un raisonnement par l'absurde. -/
@[interactive]
meta def Supposons : parse Supposons_parser → tactic unit
| (regular le) := do le.mmap' (λ b : pexpr,
                               supposons_core b.local_pp_name b.local_type)
| (absurde n hyp) := do
    by_contradiction n,
    try (interactive.push_neg (loc.ns [n])),
    when hyp.is_some (do
                         Hyp ← hyp >>= to_expr,
                         let sp := simp_arg_type.symm_expr ``(exists_prop),
                         try (interactive.simp_core {} skip tt [sp] [] $ loc.ns [n]),
                         ehyp ← get_local n,
                         change_core Hyp (some ehyp))

end tactic

example : ∀ n > 0, true :=
begin
  intro n,
  success_if_fail { Supposons H : n < 0 },
  success_if_fail { Supposons n : n > 0 },
  Supposons H : n > 0,
  trivial
end

example : ∀ n > 0, true :=
begin
  intro n,
  Supposons que H : n > 0,
  trivial
end

example : ∀ n > 0, true :=
begin
  success_if_fail { Supposons n },
  intro n,
  Supposons H : n > 0,
  trivial
end

example (P Q : Prop) (h : ¬ Q → ¬ P) : P → Q :=
begin
  Supposons hP,
  Supposons par l'absurde hnQ,
  exact h hnQ hP,
end

example (P Q : Prop) (h : ¬ Q → ¬ P) : P → Q :=
begin
  Supposons hP,
  Supposons par l'absurde hnQ : ¬ Q,
  exact h hnQ hP,
end

example (P Q : Prop) (h : Q → ¬ P) : P → ¬ Q :=
begin
  Supposons hP,
  Supposons par l'absurde hnQ : Q,
  exact h hnQ hP,
end


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

General utility functions for buffers.
-/
import data.buffer
import data.array.lemmas
import control.traversable.instances

namespace buffer

open function

variables {α : Type*} {xs : list α}

instance : inhabited (buffer α) := ⟨nil⟩

@[ext]
lemma ext : ∀ {b₁ b₂ : buffer α}, to_list b₁ = to_list b₂ → b₁ = b₂
| ⟨n₁, a₁⟩ ⟨n₂, a₂⟩ h := begin
  simp [to_list, to_array] at h,
  have e : n₁ = n₂ :=
    by rw [←array.to_list_length a₁, ←array.to_list_length a₂, h],
  subst e,
  have h : a₁ == a₂.to_list.to_array := h ▸ a₁.to_list_to_array.symm,
  rw eq_of_heq (h.trans a₂.to_list_to_array)
end

lemma ext_iff {b₁ b₂ : buffer α} : b₁ = b₂ ↔ to_list b₁ = to_list b₂ :=
⟨λ h, h ▸ rfl, ext⟩

lemma size_eq_zero_iff {b : buffer α} : b.size = 0 ↔ b = nil :=
begin
  rcases b with ⟨_|n, ⟨a⟩⟩,
  { simp only [size, nil, mk_buffer, true_and, true_iff, eq_self_iff_true, heq_iff_eq,
               sigma.mk.inj_iff],
    ext i,
    exact fin.elim0 i },
  { simp [size, nil, mk_buffer, nat.succ_ne_zero] }
end

@[simp] lemma size_nil : (@nil α).size = 0 :=
by rw size_eq_zero_iff

@[simp] lemma to_list_nil : to_list (@nil α) = [] := rfl

instance (α) [decidable_eq α] : decidable_eq (buffer α) :=
by tactic.mk_dec_eq_instance

@[simp]
lemma to_list_append_list {b : buffer α} :
  to_list (append_list b xs) = to_list b ++ xs :=
by induction xs generalizing b; simp! [*]; cases b; simp! [to_list,to_array]

@[simp]
lemma append_list_mk_buffer  :
  append_list mk_buffer xs = array.to_buffer (list.to_array xs) :=
by ext x : 1; simp [array.to_buffer,to_list,to_list_append_list];
   induction xs; [refl,skip]; simp [to_array]; refl

@[simp] lemma to_buffer_to_list (b : buffer α) : b.to_list.to_buffer = b :=
begin
  cases b,
  rw [to_list, to_array, list.to_buffer, append_list_mk_buffer],
  congr,
  { simpa },
  { apply array.to_list_to_array }
end

@[simp] lemma to_list_to_buffer (l : list α) : l.to_buffer.to_list = l :=
begin
  cases l,
  { refl },
  { rw [list.to_buffer, to_list_append_list],
    refl }
end

@[simp] lemma to_list_to_array (b : buffer α) : b.to_array.to_list = b.to_list :=
by { cases b, simp [to_list] }

@[simp] lemma append_list_nil (b : buffer α) : b.append_list [] = b := rfl

lemma to_buffer_cons (c : α) (l : list α) :
  (c :: l).to_buffer = [c].to_buffer.append_list l :=
begin
  induction l with hd tl hl,
  { simp },
  { apply ext,
    simp [hl] }
end

@[simp] lemma size_push_back (b : buffer α) (a : α) : (b.push_back a).size = b.size + 1 :=
by { cases b, simp [size, push_back] }

@[simp] lemma size_append_list (b : buffer α) (l : list α) :
  (b.append_list l).size = b.size + l.length :=
begin
  induction l with hd tl hl generalizing b,
  { simp },
  { simp [append_list, hl, add_comm, add_assoc] }
end

@[simp] lemma size_to_buffer (l : list α) : l.to_buffer.size = l.length :=
begin
  induction l with hd tl hl,
  { simpa },
  { rw [to_buffer_cons],
    have : [hd].to_buffer.size = 1 := rfl,
    simp [add_comm, this] }
end

@[simp] lemma length_to_list (b : buffer α) : b.to_list.length = b.size :=
by rw [←to_buffer_to_list b, to_list_to_buffer, size_to_buffer]

lemma size_singleton (a : α) : [a].to_buffer.size = 1 := rfl

lemma read_push_back_left (b : buffer α) (a : α) {i : ℕ} (h : i < b.size) :
  (b.push_back a).read ⟨i, by { convert nat.lt_succ_of_lt h, simp }⟩ = b.read ⟨i, h⟩ :=
by { cases b, convert array.read_push_back_left _, simp }

@[simp] lemma read_push_back_right (b : buffer α) (a : α) :
  (b.push_back a).read ⟨b.size, by simp⟩ = a :=
by { cases b, convert array.read_push_back_right }

lemma read_append_list_left' (b : buffer α) (l : list α) {i : ℕ}
  (h : i < (b.append_list l).size) (h' : i < b.size) :
  (b.append_list l).read ⟨i, h⟩ = b.read ⟨i, h'⟩ :=
begin
  induction l with hd tl hl generalizing b,
  { refl },
  { have hb : i < ((b.push_back hd).append_list tl).size := by convert h using 1,
    have hb' : i < (b.push_back hd).size := by { convert nat.lt_succ_of_lt h', simp },
    have : (append_list b (hd :: tl)).read ⟨i, h⟩ =
      read ((push_back b hd).append_list tl) ⟨i, hb⟩ := rfl,
    simp [this, hl _ hb hb', read_push_back_left _ _ h'] }
end

lemma read_append_list_left (b : buffer α) (l : list α) {i : ℕ} (h : i < b.size) :
  (b.append_list l).read ⟨i, by simpa using nat.lt_add_right _ _ _ h⟩ = b.read ⟨i, h⟩ :=
read_append_list_left' b l _ h

@[simp] lemma read_append_list_right (b : buffer α) (l : list α) {i : ℕ} (h : i < l.length) :
  (b.append_list l).read ⟨b.size + i, by simp [h]⟩ = l.nth_le i h :=
begin
  induction l with hd tl hl generalizing b i,
  { exact absurd i.zero_le (not_le_of_lt h) },
  { convert_to ((b.push_back hd).append_list tl).read _ = _,
    cases i,
    { convert read_append_list_left _ _ _;
      simp },
    { rw [list.length, nat.succ_lt_succ_iff] at h,
      have : b.size + i.succ = (b.push_back hd).size + i,
        { simp [add_comm, add_left_comm, nat.succ_eq_add_one] },
      convert hl (b.push_back hd) h using 1,
      simpa [nat.add_succ, nat.succ_add] } }
end

lemma read_to_buffer' (l : list α) {i : ℕ} (h : i < l.to_buffer.size) (h' : i < l.length) :
  l.to_buffer.read ⟨i, h⟩ = l.nth_le i h' :=
begin
  cases l with hd tl,
  { simpa using h' },
  { have hi : i < ([hd].to_buffer.append_list tl).size := by simpa [add_comm] using h,
    convert_to ([hd].to_buffer.append_list tl).read ⟨i, hi⟩ = _,
    cases i,
    { convert read_append_list_left _ _ _,
      simp },
    { rw list.nth_le,
      convert read_append_list_right _ _ _,
      simp [nat.succ_eq_add_one, add_comm] } }
end

@[simp] lemma read_to_buffer (l : list α) (i) :
  l.to_buffer.read i = l.nth_le i (by { convert i.property, simp }) :=
by { convert read_to_buffer' _ _ _, { simp }, { simpa using i.property } }

lemma nth_le_to_list' (b : buffer α) {i : ℕ} (h h') :
  b.to_list.nth_le i h = b.read ⟨i, h'⟩ :=
begin
  have : b.to_list.to_buffer.read ⟨i, (by simpa using h')⟩ = b.read ⟨i, h'⟩,
  { congr' 1; simp [fin.heq_ext_iff] },
  simp [←this]
end

lemma nth_le_to_list (b : buffer α) {i : ℕ} (h) :
  b.to_list.nth_le i h = b.read ⟨i, by simpa using h⟩ :=
nth_le_to_list' _ _ _

lemma read_eq_nth_le_to_list (b : buffer α) (i) :
  b.read i = b.to_list.nth_le i (by simpa using i.is_lt) :=
by simp [nth_le_to_list]

lemma read_singleton (c : α) : [c].to_buffer.read ⟨0, by simp⟩ = c :=
by simp

/-- The natural equivalence between lists and buffers, using
`list.to_buffer` and `buffer.to_list`. -/
def list_equiv_buffer (α : Type*) : list α ≃ buffer α :=
begin
  refine { to_fun := list.to_buffer, inv_fun := buffer.to_list, .. };
  simp [left_inverse,function.right_inverse]
end

instance : traversable buffer :=
equiv.traversable list_equiv_buffer

instance : is_lawful_traversable buffer :=
equiv.is_lawful_traversable list_equiv_buffer

/--
A convenience wrapper around `read` that just fails if the index is out of bounds.
-/
meta def read_t (b : buffer α) (i : ℕ) : tactic α :=
if h : i < b.size then return $ b.read (fin.mk i h)
else tactic.fail "invalid buffer access"

end buffer


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.monad.basic
import control.monad.cont
import control.monad.writer
import data.equiv.basic
import tactic.interactive

/-!
# Universe lifting for type families

Some functors such as `option` and `list` are universe polymorphic. Unlike
type polymorphism where `option α` is a function application and reasoning and
generalizations that apply to functions can be used, `option.{u}` and `option.{v}`
are not one function applied to two universe names but one polymorphic definition
instantiated twice. This means that whatever works on `option.{u}` is hard
to transport over to `option.{v}`. `uliftable` is an attempt at improving the situation.

`uliftable option.{u} option.{v}` gives us a generic and composable way to use
`option.{u}` in a context that requires `option.{v}`. It is often used in tandem with
`ulift` but the two are purposefully decoupled.

## Main definitions
  * `uliftable` class

## Tags

universe polymorphism functor

-/

universes u₀ u₁ v₀ v₁ v₂ w w₀ w₁
variables {s : Type u₀} {s' : Type u₁} {r r' w w' : Type*}

/-- Given a universe polymorphic type family `M.{u} : Type u₁ → Type
u₂`, this class convert between instantiations, from
`M.{u} : Type u₁ → Type u₂` to `M.{v} : Type v₁ → Type v₂` and back -/
class uliftable (f : Type u₀ → Type u₁) (g : Type v₀ → Type v₁) :=
(congr [] {α β} : α ≃ β → f α ≃ g β)

namespace uliftable

/-- The most common practical use `uliftable` (together with `up`), this function takes
`x : M.{u} α` and lifts it to M.{max u v} (ulift.{v} α) -/
@[reducible]
def up {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} : f α → g (ulift α) :=
(uliftable.congr f g equiv.ulift.symm).to_fun

/-- The most common practical use of `uliftable` (together with `up`), this function takes
`x : M.{max u v} (ulift.{v} α)` and lowers it to `M.{u} α` -/
@[reducible]
def down {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} : g (ulift α) → f α :=
(uliftable.congr f g equiv.ulift.symm).inv_fun

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_up (F : Type v₀ → Type v₁) (G : Type (max v₀ u₀) → Type u₁)
  [uliftable F G] [monad G] {α β}
  (x : F α) (f : α → G β) : G β :=
up x >>= f ∘ ulift.down

/-- convenient shortcut to avoid manipulating `ulift` -/
def adapt_down {F : Type (max u₀ v₀) → Type u₁} {G : Type v₀ → Type v₁}
  [L : uliftable G F] [monad F] {α β}
  (x : F α) (f : α → G β) : G β :=
@down.{v₀ v₁ (max u₀ v₀)} G F L β $ x >>= @up.{v₀ v₁ (max u₀ v₀)} G F L β ∘ f

/-- map function that moves up universes -/
def up_map {F : Type u₀ → Type u₁} {G : Type.{max u₀ v₀} → Type v₁} [inst : uliftable F G]
  [functor G] {α β} (f : α → β) (x : F α) : G β :=
functor.map (f ∘ ulift.down) (up x)

/-- map function that moves down universes -/
def down_map {F : Type.{max u₀ v₀} → Type u₁} {G : Type u₀ → Type v₁} [inst : uliftable G F]
  [functor F] {α β} (f : α → β) (x : F α) : G β :=
down (functor.map (ulift.up ∘ f) x : F (ulift β))

@[simp]
lemma up_down  {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} (x : g (ulift α)) : up (down x : f α) = x :=
(uliftable.congr f g equiv.ulift.symm).right_inv _

@[simp]
lemma down_up  {f : Type u₀ → Type u₁} {g : Type (max u₀ v₀) → Type v₁} [uliftable f g]
  {α} (x : f α) : down (up x : g _) = x :=
(uliftable.congr f g equiv.ulift.symm).left_inv _

end uliftable

open ulift

instance : uliftable id id :=
{ congr := λ α β F, F }

/-- for specific state types, this function helps to create a uliftable instance -/
def state_t.uliftable' {m : Type u₀ → Type v₀} {m' : Type u₁ → Type v₁}
  [uliftable m m']
  (F : s ≃ s') :
  uliftable (state_t s m) (state_t s' m') :=
{ congr :=
    λ α β G, state_t.equiv $ equiv.Pi_congr F $
      λ _, uliftable.congr _ _ $ equiv.prod_congr G F }

instance {m m'} [uliftable m m'] :
  uliftable (state_t s m) (state_t (ulift s) m') :=
state_t.uliftable' equiv.ulift.symm

/-- for specific reader monads, this function helps to create a uliftable instance -/
def reader_t.uliftable' {m m'} [uliftable m m']
  (F : s ≃ s') :
  uliftable (reader_t s m) (reader_t s' m') :=
{ congr :=
    λ α β G, reader_t.equiv $ equiv.Pi_congr F $
      λ _, uliftable.congr _ _ G }

instance {m m'} [uliftable m m'] : uliftable (reader_t s m) (reader_t (ulift s) m') :=
reader_t.uliftable' equiv.ulift.symm

/-- for specific continuation passing monads, this function helps to create a uliftable instance -/
def cont_t.uliftable' {m m'} [uliftable m m']
  (F : r ≃ r') :
  uliftable (cont_t r m) (cont_t r' m') :=
{ congr :=
    λ α β, cont_t.equiv (uliftable.congr _ _ F) }

instance {s m m'} [uliftable m m'] : uliftable (cont_t s m) (cont_t (ulift s) m') :=
cont_t.uliftable' equiv.ulift.symm

/-- for specific writer monads, this function helps to create a uliftable instance -/
def writer_t.uliftable' {m m'} [uliftable m m']
  (F : w ≃ w') :
  uliftable (writer_t w m) (writer_t w' m') :=
{ congr :=
    λ α β G, writer_t.equiv $ uliftable.congr _ _ $ equiv.prod_congr G F }

instance {m m'} [uliftable m m'] : uliftable (writer_t s m) (writer_t (ulift s) m') :=
writer_t.uliftable' equiv.ulift.symm


/-
Copyright (c) 2022 Yaël Dillies. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies

! This file was ported from Lean 3 source module logic.lemmas
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.Congr
import Mathbin.Tactic.Protected
import Mathbin.Tactic.Rcases
import Mathbin.Tactic.SplitIfs
import Mathbin.Logic.Basic

/-!
# More basic logic properties

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

A few more logic lemmas. These are in their own file, rather than `logic.basic`, because it is
convenient to be able to use the `split_ifs` tactic.

## Implementation notes

We spell those lemmas out with `dite` and `ite` rather than the `if then else` notation because this
would result in less delta-reduced statements.
-/

alias heq_iff_eq ↔ HEq.eq Eq.heq
#align heq.eq HEq.eq
#align eq.heq Eq.heq

attribute [protected] HEq.eq Eq.heq

alias ne_of_eq_of_ne ← Eq.trans_ne
#align eq.trans_ne Eq.trans_ne

alias ne_of_ne_of_eq ← Ne.trans_eq
#align ne.trans_eq Ne.trans_eq

variable {α : Sort _} {p q r : Prop} [Decidable p] [Decidable q] {a b c : α}

#print dite_dite_distrib_left /-
theorem dite_dite_distrib_left {a : p → α} {b : ¬p → q → α} {c : ¬p → ¬q → α} :
    (dite p a fun hp => dite q (b hp) (c hp)) =
      dite q (fun hq => dite p a fun hp => b hp hq) fun hq => dite p a fun hp => c hp hq :=
  by split_ifs <;> rfl
#align dite_dite_distrib_left dite_dite_distrib_left
-/

#print dite_dite_distrib_right /-
theorem dite_dite_distrib_right {a : p → q → α} {b : p → ¬q → α} {c : ¬p → α} :
    dite p (fun hp => dite q (a hp) (b hp)) c =
      dite q (fun hq => dite p (fun hp => a hp hq) c) fun hq => dite p (fun hp => b hp hq) c :=
  by split_ifs <;> rfl
#align dite_dite_distrib_right dite_dite_distrib_right
-/

#print ite_dite_distrib_left /-
theorem ite_dite_distrib_left {a : α} {b : q → α} {c : ¬q → α} :
    ite p a (dite q b c) = dite q (fun hq => ite p a <| b hq) fun hq => ite p a <| c hq :=
  dite_dite_distrib_left
#align ite_dite_distrib_left ite_dite_distrib_left
-/

#print ite_dite_distrib_right /-
theorem ite_dite_distrib_right {a : q → α} {b : ¬q → α} {c : α} :
    ite p (dite q a b) c = dite q (fun hq => ite p (a hq) c) fun hq => ite p (b hq) c :=
  dite_dite_distrib_right
#align ite_dite_distrib_right ite_dite_distrib_right
-/

#print dite_ite_distrib_left /-
theorem dite_ite_distrib_left {a : p → α} {b : ¬p → α} {c : ¬p → α} :
    (dite p a fun hp => ite q (b hp) (c hp)) = ite q (dite p a b) (dite p a c) :=
  dite_dite_distrib_left
#align dite_ite_distrib_left dite_ite_distrib_left
-/

#print dite_ite_distrib_right /-
theorem dite_ite_distrib_right {a : p → α} {b : p → α} {c : ¬p → α} :
    dite p (fun hp => ite q (a hp) (b hp)) c = ite q (dite p a c) (dite p b c) :=
  dite_dite_distrib_right
#align dite_ite_distrib_right dite_ite_distrib_right
-/

#print ite_ite_distrib_left /-
theorem ite_ite_distrib_left : ite p a (ite q b c) = ite q (ite p a b) (ite p a c) :=
  dite_dite_distrib_left
#align ite_ite_distrib_left ite_ite_distrib_left
-/

#print ite_ite_distrib_right /-
theorem ite_ite_distrib_right : ite p (ite q a b) c = ite q (ite p a c) (ite p b c) :=
  dite_dite_distrib_right
#align ite_ite_distrib_right ite_ite_distrib_right
-/

#print Prop.forall /-
theorem Prop.forall {f : Prop → Prop} : (∀ p, f p) ↔ f True ∧ f False :=
  ⟨fun h => ⟨h _, h _⟩, by
    rintro ⟨h₁, h₀⟩ p
    by_cases hp : p <;> simp only [hp] <;> assumption⟩
#align Prop.forall Prop.forall
-/

#print Prop.exists /-
theorem Prop.exists {f : Prop → Prop} : (∃ p, f p) ↔ f True ∨ f False :=
  ⟨fun ⟨p, h⟩ => by refine' (em p).imp _ _ <;> intro H <;> convert h <;> simp [H], by
    rintro (h | h) <;> exact ⟨_, h⟩⟩
#align Prop.exists Prop.exists
-/


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin
-/

import category_theory.limits.preserves
import category_theory.whiskering
import category_theory.equivalence

namespace category_theory
open category
open category_theory.limits

universes v₁ v₂ v₃ u₁ u₂ u₃ -- declare the `v`'s first; see `category_theory.category` for an explanation

local attribute [elab_simple] whisker_left whisker_right

variables {C : Type u₁} [𝒞 : category.{v₁} C] {D : Type u₂} [𝒟 : category.{v₂} D]
include 𝒞 𝒟

/--
`adjunction F G` represents the data of an adjunction between two functors
`F : C ⥤ D` and `G : D ⥤ C`. `F` is the left adjoint and `G` is the right adjoint.
-/
structure adjunction (F : C ⥤ D) (G : D ⥤ C) :=
(hom_equiv : Π (X Y), (F.obj X ⟶ Y) ≃ (X ⟶ G.obj Y))
(unit : functor.id C ⟶ F.comp G)
(counit : G.comp F ⟶ functor.id D)
(hom_equiv_unit' : Π {X Y f}, (hom_equiv X Y) f = (unit : _ ⟹ _).app X ≫ G.map f . obviously)
(hom_equiv_counit' : Π {X Y g}, (hom_equiv X Y).symm g = F.map g ≫ counit.app Y . obviously)

namespace adjunction

restate_axiom hom_equiv_unit'
restate_axiom hom_equiv_counit'
attribute [simp, priority 1] hom_equiv_unit hom_equiv_counit

section

variables {F : C ⥤ D} {G : D ⥤ C} (adj : adjunction F G) {X' X : C} {Y Y' : D}

@[simp, priority 1] lemma hom_equiv_naturality_left_symm (f : X' ⟶ X) (g : X ⟶ G.obj Y) :
  (adj.hom_equiv X' Y).symm (f ≫ g) = F.map f ≫ (adj.hom_equiv X Y).symm g :=
by rw [hom_equiv_counit, F.map_comp, assoc, adj.hom_equiv_counit.symm]

@[simp] lemma hom_equiv_naturality_left (f : X' ⟶ X) (g : F.obj X ⟶ Y) :
  (adj.hom_equiv X' Y) (F.map f ≫ g) = f ≫ (adj.hom_equiv X Y) g :=
by rw [← equiv.eq_symm_apply]; simp [-hom_equiv_unit]

@[simp, priority 1] lemma hom_equiv_naturality_right (f : F.obj X ⟶ Y) (g : Y ⟶ Y') :
  (adj.hom_equiv X Y') (f ≫ g) = (adj.hom_equiv X Y) f ≫ G.map g :=
by rw [hom_equiv_unit, G.map_comp, ← assoc, ←hom_equiv_unit]

@[simp] lemma hom_equiv_naturality_right_symm (f : X ⟶ G.obj Y) (g : Y ⟶ Y') :
  (adj.hom_equiv X Y').symm (f ≫ G.map g) = (adj.hom_equiv X Y).symm f ≫ g :=
by rw [equiv.symm_apply_eq]; simp [-hom_equiv_counit]

@[simp] lemma left_triangle :
  (whisker_right adj.unit F).vcomp (whisker_left F adj.counit) = nat_trans.id _ :=
begin
  ext1 X, dsimp,
  erw [← adj.hom_equiv_counit, equiv.symm_apply_eq, adj.hom_equiv_unit],
  simp
end

@[simp] lemma right_triangle :
  (whisker_left G adj.unit).vcomp (whisker_right adj.counit G) = nat_trans.id _ :=
begin
  ext1 Y, dsimp,
  erw [← adj.hom_equiv_unit, ← equiv.eq_symm_apply, adj.hom_equiv_counit],
  simp
end

@[simp] lemma left_triangle_components :
  F.map (adj.unit.app X) ≫ adj.counit.app (F.obj X) = 𝟙 _ :=
congr_arg (λ (t : _ ⟹ functor.id C ⋙ F), t.app X) adj.left_triangle

@[simp] lemma right_triangle_components {Y : D} :
  adj.unit.app (G.obj Y) ≫ G.map (adj.counit.app Y) = 𝟙 _ :=
congr_arg (λ (t : _ ⟹ G ⋙ functor.id C), t.app Y) adj.right_triangle

end

structure core_hom_equiv (F : C ⥤ D) (G : D ⥤ C) :=
(hom_equiv : Π (X Y), (F.obj X ⟶ Y) ≃ (X ⟶ G.obj Y))
(hom_equiv_naturality_left_symm' : Π {X' X Y} (f : X' ⟶ X) (g : X ⟶ G.obj Y),
  (hom_equiv X' Y).symm (f ≫ g) = F.map f ≫ (hom_equiv X Y).symm g . obviously)
(hom_equiv_naturality_right' : Π {X Y Y'} (f : F.obj X ⟶ Y) (g : Y ⟶ Y'),
  (hom_equiv X Y') (f ≫ g) = (hom_equiv X Y) f ≫ G.map g . obviously)

namespace core_hom_equiv

restate_axiom hom_equiv_naturality_left_symm'
restate_axiom hom_equiv_naturality_right'
attribute [simp, priority 1] hom_equiv_naturality_left_symm hom_equiv_naturality_right

variables {F : C ⥤ D} {G : D ⥤ C} (adj : core_hom_equiv F G) {X' X : C} {Y Y' : D}

@[simp] lemma hom_equiv_naturality_left (f : X' ⟶ X) (g : F.obj X ⟶ Y) :
  (adj.hom_equiv X' Y) (F.map f ≫ g) = f ≫ (adj.hom_equiv X Y) g :=
by rw [← equiv.eq_symm_apply]; simp

@[simp] lemma hom_equiv_naturality_right_symm (f : X ⟶ G.obj Y) (g : Y ⟶ Y') :
  (adj.hom_equiv X Y').symm (f ≫ G.map g) = (adj.hom_equiv X Y).symm f ≫ g :=
by rw [equiv.symm_apply_eq]; simp

end core_hom_equiv

structure core_unit_counit (F : C ⥤ D) (G : D ⥤ C) :=
(unit : functor.id C ⟶ F.comp G)
(counit : G.comp F ⟶ functor.id D)
(left_triangle' : (whisker_right unit F).vcomp (whisker_left F counit) = nat_trans.id _ . obviously)
(right_triangle' : (whisker_left G unit).vcomp (whisker_right counit G) = nat_trans.id _ . obviously)

namespace core_unit_counit

restate_axiom left_triangle'
restate_axiom right_triangle'
attribute [simp] left_triangle right_triangle

end core_unit_counit

variables (F : C ⥤ D) (G : D ⥤ C)

def mk_of_hom_equiv (adj : core_hom_equiv F G) : adjunction F G :=
{ unit :=
  { app := λ X, (adj.hom_equiv X (F.obj X)) (𝟙 (F.obj X)),
    naturality' :=
    begin
      intros,
      erw [← adj.hom_equiv_naturality_left, ← adj.hom_equiv_naturality_right],
      dsimp, simp
    end },
  counit :=
  { app := λ Y, (adj.hom_equiv _ _).inv_fun (𝟙 (G.obj Y)),
    naturality' :=
    begin
      intros,
      erw [← adj.hom_equiv_naturality_left_symm, ← adj.hom_equiv_naturality_right_symm],
      dsimp, simp
    end },
  hom_equiv_unit' := λ X Y f, by erw [← adj.hom_equiv_naturality_right]; simp,
  hom_equiv_counit' := λ X Y f, by erw [← adj.hom_equiv_naturality_left_symm]; simp,
  .. adj }

def mk_of_unit_counit (adj : core_unit_counit F G) : adjunction F G :=
{ hom_equiv := λ X Y,
  { to_fun := λ f, adj.unit.app X ≫ G.map f,
    inv_fun := λ g, F.map g ≫ adj.counit.app Y,
    left_inv := λ f, begin
      change F.map (_ ≫ _) ≫ _ = _,
      rw [F.map_comp, assoc, ←functor.comp_map, adj.counit.naturality, ←assoc],
      convert id_comp _ f,
      exact congr_arg (λ t : _ ⟹ _, t.app _) adj.left_triangle
    end,
    right_inv := λ g, begin
      change _ ≫ G.map (_ ≫ _) = _,
      rw [G.map_comp, ←assoc, ←functor.comp_map, ←adj.unit.naturality, assoc],
      convert comp_id _ g,
      exact congr_arg (λ t : _ ⟹ _, t.app _) adj.right_triangle
  end },
  .. adj }

section
omit 𝒟

def id : adjunction (functor.id C) (functor.id C) :=
{ hom_equiv := λ X Y, equiv.refl _,
  unit := 𝟙 _,
  counit := 𝟙 _ }

end

/-
TODO
* define adjoint equivalences
* show that every equivalence can be improved into an adjoint equivalence
-/

section
variables {E : Type u₃} [ℰ : category.{v₃} E] (H : D ⥤ E) (I : E ⥤ D)

def comp (adj₁ : adjunction F G) (adj₂ : adjunction H I) : adjunction (F ⋙ H) (I ⋙ G) :=
{ hom_equiv := λ X Z, equiv.trans (adj₂.hom_equiv _ _) (adj₁.hom_equiv _ _),
  unit := adj₁.unit ≫
  (whisker_left F $ whisker_right adj₂.unit G) ≫ (functor.associator _ _ _).inv,
  counit := (functor.associator _ _ _).hom ≫
    (whisker_left I $ whisker_right adj₁.counit H) ≫ adj₂.counit }

end

structure is_left_adjoint (left : C ⥤ D) :=
(right : D ⥤ C)
(adj : adjunction left right)

structure is_right_adjoint (right : D ⥤ C) :=
(left : C ⥤ D)
(adj : adjunction left right)

section construct_left
-- Construction of a left adjoint. In order to construct a left
-- adjoint to a functor G : D → C, it suffices to give the object part
-- of a functor F : C → D together with isomorphisms Hom(FX, Y) ≃
-- Hom(X, GY) natural in Y. The action of F on morphisms can be
-- constructed from this data.
variables {F_obj : C → D} {G}
variables (e : Π X Y, (F_obj X ⟶ Y) ≃ (X ⟶ G.obj Y))
variables (he : Π X Y Y' g h, e X Y' (h ≫ g) = e X Y h ≫ G.map g)
include he

private lemma he' {X Y Y'} (f g) : (e X Y').symm (f ≫ G.map g) = (e X Y).symm f ≫ g :=
by intros; rw [equiv.symm_apply_eq, he]; simp

def left_adjoint_of_equiv : C ⥤ D :=
{ obj := F_obj,
  map := λ X X' f, (e X (F_obj X')).symm (f ≫ e X' (F_obj X') (𝟙 _)),
  map_comp' := λ X X' X'' f f', begin
    rw [equiv.symm_apply_eq, he, equiv.apply_symm_apply],
    conv { to_rhs, rw [assoc, ←he, id_comp, equiv.apply_symm_apply] },
    simp
  end }

def adjunction_of_equiv_left : adjunction (left_adjoint_of_equiv e he) G :=
mk_of_hom_equiv (left_adjoint_of_equiv e he) G
{ hom_equiv := e,
  hom_equiv_naturality_left_symm' :=
  begin
    intros,
    erw [← he' e he, ← equiv.apply_eq_iff_eq],
    simp [(he _ _ _ _ _).symm]
  end }

end construct_left

section construct_right
-- Construction of a right adjoint, analogous to the above.
variables {F} {G_obj : D → C}
variables (e : Π X Y, (F.obj X ⟶ Y) ≃ (X ⟶ G_obj Y))
variables (he : Π X' X Y f g, e X' Y (F.map f ≫ g) = f ≫ e X Y g)
include he

private lemma he' {X' X Y} (f g) : F.map f ≫ (e X Y).symm g = (e X' Y).symm (f ≫ g) :=
by intros; rw [equiv.eq_symm_apply, he]; simp

def right_adjoint_of_equiv : D ⥤ C :=
{ obj := G_obj,
  map := λ Y Y' g, (e (G_obj Y) Y') ((e (G_obj Y) Y).symm (𝟙 _) ≫ g),
  map_comp' := λ Y Y' Y'' g g', begin
    rw [← equiv.eq_symm_apply, ← he' e he, equiv.symm_apply_apply],
    conv { to_rhs, rw [← assoc, he' e he, comp_id, equiv.symm_apply_apply] },
    simp
  end }

def adjunction_of_equiv_right : adjunction F (right_adjoint_of_equiv e he) :=
mk_of_hom_equiv F (right_adjoint_of_equiv e he)
{ hom_equiv := e,
  hom_equiv_naturality_left_symm' := by intros; rw [equiv.symm_apply_eq, he]; simp,
  hom_equiv_naturality_right' :=
  begin
    intros X Y Y' g h,
    erw [←he, equiv.apply_eq_iff_eq, ←assoc, he' e he, comp_id, equiv.symm_apply_apply]
  end }

end construct_right

end adjunction

end category_theory

namespace category_theory.adjunction
open category_theory
open category_theory.functor
open category_theory.limits

universes u₁ u₂ v

variables {C : Type u₁} [𝒞 : category.{v} C] {D : Type u₂} [𝒟 : category.{v} D]
include 𝒞 𝒟

variables {F : C ⥤ D} {G : D ⥤ C} (adj : adjunction F G)
include adj

section preservation_colimits
variables {J : Type v} [small_category J] (K : J ⥤ C)

def functoriality_is_left_adjoint :
  is_left_adjoint (@cocones.functoriality _ _ _ _ K _ _ F) :=
{ right := (cocones.functoriality G) ⋙ (cocones.precompose
    (K.right_unitor.inv ≫ (whisker_left K adj.unit) ≫ (associator _ _ _).inv)),
  adj := mk_of_unit_counit _ _
  { unit :=
    { app := λ c,
      { hom := adj.unit.app c.X,
        w' := λ j, by have := adj.unit.naturality (c.ι.app j); tidy },
      naturality' := λ _ _ f, by have := adj.unit.naturality (f.hom); tidy },
    counit :=
    { app := λ c,
      { hom := adj.counit.app c.X,
        w' :=
        begin
          intro j,
          dsimp,
          erw [category.comp_id, category.id_comp, F.map_comp, category.assoc,
            adj.counit.naturality (c.ι.app j), ← category.assoc,
            adj.left_triangle_components, category.id_comp],
          refl,
        end },
      naturality' := λ _ _ f, by have := adj.counit.naturality (f.hom); tidy } } }

/-- A left adjoint preserves colimits. -/
def left_adjoint_preserves_colimits : preserves_colimits F :=
λ J 𝒥 K, by resetI; exact
{ preserves := λ c hc, is_colimit_iso_unique_cocone_morphism.inv
    (λ s, (((adj.functoriality_is_left_adjoint _).adj).hom_equiv _ _).unique_of_equiv $
      is_colimit_iso_unique_cocone_morphism.hom hc _ ) }

end preservation_colimits

section preservation_limits
variables {J : Type v} [small_category J] (K : J ⥤ D)

def functoriality_is_right_adjoint :
  is_right_adjoint (@cones.functoriality _ _ _ _ K _ _ G) :=
{ left := (cones.functoriality F) ⋙ (cones.postcompose
    ((associator _ _ _).hom ≫ (whisker_left K adj.counit) ≫ K.right_unitor.hom)),
  adj := mk_of_unit_counit _ _
  { unit :=
    { app := λ c,
      { hom := adj.unit.app c.X,
        w' :=
        begin
          intro j,
          dsimp,
          erw [category.comp_id, category.id_comp, G.map_comp, ← category.assoc,
            ← adj.unit.naturality (c.π.app j), category.assoc,
            adj.right_triangle_components, category.comp_id],
          refl,
        end },
      naturality' := λ _ _ f, by have := adj.unit.naturality (f.hom); tidy },
    counit :=
    { app := λ c,
      { hom := adj.counit.app c.X,
        w' := λ j, by have := adj.counit.naturality (c.π.app j); tidy },
      naturality' := λ _ _ f, by have := adj.counit.naturality (f.hom); tidy } } }

/-- A right adjoint preserves limits. -/
def right_adjoint_preserves_limits : preserves_limits G :=
λ J 𝒥 K, by resetI; exact
{ preserves := λ c hc, is_limit_iso_unique_cone_morphism.inv
    (λ s, (((adj.functoriality_is_right_adjoint _).adj).hom_equiv _ _).symm.unique_of_equiv $
      is_limit_iso_unique_cone_morphism.hom hc _) }

end preservation_limits

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
def cocones_iso {J : Type v} [small_category J] {K : J ⥤ C} :
  (cocones J D).obj (op (K ⋙ F)) ≅ G ⋙ ((cocones J C).obj (op K)) :=
nat_iso.of_components (λ Y,
{ hom := λ t,
    { app := λ j, (adj.hom_equiv (K.obj j) Y) (t.app j),
      naturality' := λ j j' f, by erw [← adj.hom_equiv_naturality_left, t.naturality]; dsimp; simp },
  inv := λ t,
    { app := λ j, (adj.hom_equiv (K.obj j) Y).symm (t.app j),
      naturality' := λ j j' f, begin
        erw [← adj.hom_equiv_naturality_left_symm, ← adj.hom_equiv_naturality_right_symm, t.naturality],
        dsimp, simp
      end } } )
begin
  intros Y₁ Y₂ f,
  ext1 t,
  ext1 j,
  apply adj.hom_equiv_naturality_right
end

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
def cones_iso {J : Type v} [small_category J] {K : J ⥤ D} :
  F.op ⋙ ((cones J D).obj K) ≅ (cones J C).obj (K ⋙ G) :=
nat_iso.of_components (λ X,
{ hom := λ t,
  { app := λ j, (adj.hom_equiv (unop X) (K.obj j)) (t.app j),
    naturality' := λ j j' f, begin
      erw [← adj.hom_equiv_naturality_right, ← t.naturality, category.id_comp, category.id_comp],
      refl
    end },
  inv := λ t,
  { app := λ j, (adj.hom_equiv (unop X) (K.obj j)).symm (t.app j),
    naturality' := λ j j' f, begin
      erw [← adj.hom_equiv_naturality_right_symm, ← t.naturality, category.id_comp, category.id_comp]
    end } } )
(by tidy)

end category_theory.adjunction