/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.homology.homology
import algebra.homology.single
import category_theory.preadditive.additive_functor

/-!
# Homology is an additive functor

When `V` is preadditive, `homological_complex V c` is also preadditive,
and `homology_functor` is additive.

TODO: similarly for `R`-linear.
-/

universes v u

open_locale classical
noncomputable theory

open category_theory category_theory.category category_theory.limits homological_complex

variables {ι : Type*}
variables {V : Type u} [category.{v} V] [preadditive V]

variables {c : complex_shape ι} {C D E : homological_complex V c}
variables (f g : C ⟶ D) (h k : D ⟶ E) (i : ι)

namespace homological_complex

instance : has_zero (C ⟶ D) := ⟨{ f := λ i, 0 }⟩
instance : has_add (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i + g.f i, }⟩
instance : has_neg (C ⟶ D) := ⟨λ f, { f := λ i, -(f.f i) }⟩
instance : has_sub (C ⟶ D) := ⟨λ f g, { f := λ i, f.f i - g.f i, }⟩
instance has_nat_scalar : has_smul ℕ (C ⟶ D) := ⟨λ n f,
  { f := λ i, n • f.f i,
    comm' := λ i j h, by simp [preadditive.nsmul_comp, preadditive.comp_nsmul] }⟩
instance has_int_scalar : has_smul ℤ (C ⟶ D) := ⟨λ n f,
  { f := λ i, n • f.f i,
    comm' := λ i j h, by simp [preadditive.zsmul_comp, preadditive.comp_zsmul] }⟩

@[simp] lemma zero_f_apply (i : ι) : (0 : C ⟶ D).f i = 0 := rfl
@[simp] lemma add_f_apply (f g : C ⟶ D) (i : ι) : (f + g).f i = f.f i + g.f i := rfl
@[simp] lemma neg_f_apply (f : C ⟶ D) (i : ι) : (-f).f i = -(f.f i) := rfl
@[simp] lemma sub_f_apply (f g : C ⟶ D) (i : ι) : (f - g).f i = f.f i - g.f i := rfl
@[simp] lemma nsmul_f_apply (n : ℕ) (f : C ⟶ D) (i : ι) : (n • f).f i = n • f.f i := rfl
@[simp] lemma zsmul_f_apply (n : ℤ) (f : C ⟶ D) (i : ι) : (n • f).f i = n • f.f i := rfl

instance : add_comm_group (C ⟶ D) :=
function.injective.add_comm_group hom.f
  homological_complex.hom_f_injective (by tidy) (by tidy) (by tidy) (by tidy) (by tidy) (by tidy)

instance : preadditive (homological_complex V c) := {}

/-- The `i`-th component of a chain map, as an additive map from chain maps to morphisms. -/
@[simps]
def hom.f_add_monoid_hom {C₁ C₂ : homological_complex V c} (i : ι) :
  (C₁ ⟶ C₂) →+ (C₁.X i ⟶ C₂.X i) :=
add_monoid_hom.mk' (λ f, hom.f f i) (λ _ _, rfl)

end homological_complex

namespace homological_complex

instance eval_additive (i : ι) : (eval V c i).additive := {}

instance cycles_additive [has_equalizers V] : (cycles_functor V c i).additive := {}

variables [has_images V] [has_image_maps V]

instance boundaries_additive : (boundaries_functor V c i).additive := {}

variables [has_equalizers V] [has_cokernels V]

instance homology_additive : (homology_functor V c i).additive :=
{ map_add' := λ C D f g, begin
    dsimp [homology_functor],
    ext,
    simp only [homology.π_map, preadditive.comp_add, ←preadditive.add_comp],
    congr,
    ext, simp,
  end }

end homological_complex

namespace category_theory

variables {W : Type*} [category W] [preadditive W]

/--
An additive functor induces a functor between homological complexes.
This is sometimes called the "prolongation".
-/
@[simps]
def functor.map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) :
  homological_complex V c ⥤ homological_complex W c :=
{ obj := λ C,
  { X := λ i, F.obj (C.X i),
    d := λ i j, F.map (C.d i j),
    shape' := λ i j w, by rw [C.shape _ _ w, F.map_zero],
    d_comp_d' := λ i j k _ _, by rw [←F.map_comp, C.d_comp_d, F.map_zero], },
  map := λ C D f,
  { f := λ i, F.map (f.f i),
    comm' := λ i j h, by { dsimp,  rw [←F.map_comp, ←F.map_comp, f.comm], }, }, }.

variable (V)

/-- The functor on homological complexes induced by the identity functor is
isomorphic to the identity functor. -/
@[simps]
def functor.map_homological_complex_id_iso (c : complex_shape ι) :
  (𝟭 V).map_homological_complex c ≅ 𝟭 _ :=
nat_iso.of_components (λ K, hom.iso_of_components (λ i, iso.refl _) (by tidy)) (by tidy)

variable {V}

instance functor.map_homogical_complex_additive
  (F : V ⥤ W) [F.additive] (c : complex_shape ι) : (F.map_homological_complex c).additive := {}

instance functor.map_homological_complex_reflects_iso
  (F : V ⥤ W) [F.additive] [reflects_isomorphisms F] (c : complex_shape ι) :
  reflects_isomorphisms (F.map_homological_complex c) :=
⟨λ X Y f, begin
  introI,
  haveI : ∀ (n : ι), is_iso (F.map (f.f n)) := λ n, is_iso.of_iso
    ((homological_complex.eval W c n).map_iso (as_iso ((F.map_homological_complex c).map f))),
  haveI := λ n, is_iso_of_reflects_iso (f.f n) F,
  exact homological_complex.hom.is_iso_of_components f,
end⟩

/--
A natural transformation between functors induces a natural transformation
between those functors applied to homological complexes.
-/
@[simps]
def nat_trans.map_homological_complex {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ⟶ G) (c : complex_shape ι) : F.map_homological_complex c ⟶ G.map_homological_complex c :=
{ app := λ C, { f := λ i, α.app _, }, }

@[simp] lemma nat_trans.map_homological_complex_id (c : complex_shape ι) (F : V ⥤ W) [F.additive] :
  nat_trans.map_homological_complex (𝟙 F) c = 𝟙 (F.map_homological_complex c) :=
by tidy

@[simp] lemma nat_trans.map_homological_complex_comp (c : complex_shape ι)
  {F G H : V ⥤ W} [F.additive] [G.additive] [H.additive]
  (α : F ⟶ G) (β : G ⟶ H):
  nat_trans.map_homological_complex (α ≫ β) c =
    nat_trans.map_homological_complex α c ≫ nat_trans.map_homological_complex β c :=
by tidy

@[simp, reassoc] lemma nat_trans.map_homological_complex_naturality {c : complex_shape ι}
  {F G : V ⥤ W} [F.additive] [G.additive] (α : F ⟶ G) {C D : homological_complex V c} (f : C ⟶ D) :
  (F.map_homological_complex c).map f ≫ (nat_trans.map_homological_complex α c).app D =
    (nat_trans.map_homological_complex α c).app C ≫ (G.map_homological_complex c).map f :=
by tidy

/--
A natural isomorphism between functors induces a natural isomorphism
between those functors applied to homological complexes.
-/
@[simps]
def nat_iso.map_homological_complex {F G : V ⥤ W} [F.additive] [G.additive]
  (α : F ≅ G) (c : complex_shape ι) : F.map_homological_complex c ≅ G.map_homological_complex c :=
{ hom := α.hom.map_homological_complex c,
  inv := α.inv.map_homological_complex c,
  hom_inv_id' := by simpa only [← nat_trans.map_homological_complex_comp, α.hom_inv_id],
  inv_hom_id' := by simpa only [← nat_trans.map_homological_complex_comp, α.inv_hom_id], }

/--
An equivalence of categories induces an equivalences between the respective categories
of homological complex.
-/
@[simps]
def equivalence.map_homological_complex (e : V ≌ W) [e.functor.additive] (c : complex_shape ι):
  homological_complex V c ≌ homological_complex W c :=
{ functor := e.functor.map_homological_complex c,
  inverse := e.inverse.map_homological_complex c,
  unit_iso := (functor.map_homological_complex_id_iso V c).symm ≪≫
    nat_iso.map_homological_complex e.unit_iso c,
  counit_iso := nat_iso.map_homological_complex e.counit_iso c ≪≫
    functor.map_homological_complex_id_iso W c, }

end category_theory

namespace chain_complex

variables {W : Type*} [category W] [preadditive W]
variables {α : Type*} [add_right_cancel_semigroup α] [has_one α] [decidable_eq α]

lemma map_chain_complex_of (F : V ⥤ W) [F.additive] (X : α → V) (d : Π n, X (n+1) ⟶ X n)
  (sq : ∀ n, d (n+1) ≫ d n = 0) :
  (F.map_homological_complex _).obj (chain_complex.of X d sq) =
  chain_complex.of (λ n, F.obj (X n))
    (λ n, F.map (d n)) (λ n, by rw [ ← F.map_comp, sq n, functor.map_zero]) :=
begin
  refine homological_complex.ext rfl _,
  rintro i j (rfl : j + 1 = i),
  simp only [category_theory.functor.map_homological_complex_obj_d, of_d,
    eq_to_hom_refl, comp_id, id_comp],
end

end chain_complex

variables [has_zero_object V] {W : Type*} [category W] [preadditive W] [has_zero_object W]

namespace homological_complex

local attribute [simp] eq_to_hom_map

/--
Turning an object into a complex supported at `j` then applying a functor is
the same as applying the functor then forming the complex.
-/
def single_map_homological_complex (F : V ⥤ W) [F.additive] (c : complex_shape ι) (j : ι):
  single V c j ⋙ F.map_homological_complex _ ≅ F ⋙ single W c j :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  inv := { f := λ i, if h : i = j then
    eq_to_hom (by simp [h])
  else
    0, },
  hom_inv_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, },
  end,
  inv_hom_id' := begin
    ext i,
    dsimp,
    split_ifs with h,
    { simp [h] },
    { rw [zero_comp, if_neg h],
      simp, },
  end, })
  (λ X Y f, begin
    ext i,
    dsimp,
    split_ifs with h; simp [h],
  end).

variables (F : V ⥤ W) [functor.additive F] (c)

@[simp] lemma single_map_homological_complex_hom_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_hom_app_ne
  {i j : ι} (h : i ≠ j) (X : V) :
  ((single_map_homological_complex F c j).hom.app X).f i = 0 :=
by simp [single_map_homological_complex, h]
@[simp] lemma single_map_homological_complex_inv_app_self (j : ι) (X : V) :
  ((single_map_homological_complex F c j).inv.app X).f j = eq_to_hom (by simp) :=
by simp [single_map_homological_complex]
@[simp] lemma single_map_homological_complex_inv_app_ne
  {i j : ι} (h : i ≠ j) (X : V):
  ((single_map_homological_complex F c j).inv.app X).f i = 0 :=
by simp [single_map_homological_complex, h]

end homological_complex

namespace chain_complex

/--
Turning an object into a chain complex supported at zero then applying a functor is
the same as applying the functor then forming the complex.
-/
def single₀_map_homological_complex (F : V ⥤ W) [F.additive] :
  single₀ V ⋙ F.map_homological_complex _ ≅ F ⋙ single₀ W :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.hom
    end, },
  inv := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.inv
    end, },
  hom_inv_id' := begin
    ext (_|i),
    { unfold_aux, simp, },
    { unfold_aux,
      dsimp,
      simp only [comp_f, id_f, zero_comp],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, }
  end,
  inv_hom_id' := by { ext (_|i); { unfold_aux, dsimp, simp, }, }, })
  (λ X Y f, by { ext (_|i); { unfold_aux, dsimp, simp, }, }).

@[simp]

end chain_complex

namespace cochain_complex

/--
Turning an object into a cochain complex supported at zero then applying a functor is
the same as applying the functor then forming the cochain complex.
-/
def single₀_map_homological_complex (F : V ⥤ W) [F.additive] :
  single₀ V ⋙ F.map_homological_complex _ ≅ F ⋙ single₀ W :=
nat_iso.of_components (λ X,
{ hom := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.hom
    end, },
  inv := { f := λ i, match i with
    | 0 := 𝟙 _
    | (i+1) := F.map_zero_object.inv
    end, },
  hom_inv_id' := begin
    ext (_|i),
    { unfold_aux, simp, },
    { unfold_aux,
      dsimp,
      simp only [comp_f, id_f, zero_comp],
      exact (zero_of_source_iso_zero _ F.map_zero_object).symm, }
  end,
  inv_hom_id' := by { ext (_|i); { unfold_aux, dsimp, simp, }, }, })
  (λ X Y f, by { ext (_|i); { unfold_aux, dsimp, simp, }, }).

@[simp] lemma single₀_map_homological_complex_hom_app_zero (F : V ⥤ W) [F.additive] (X : V) :
  ((single₀_map_homological_complex F).hom.app X).f 0 = 𝟙 _ := rfl
@[simp] lemma single₀_map_homological_complex_hom_app_succ
  (F : V ⥤ W) [F.additive] (X : V) (n : ℕ) :
  ((single₀_map_homological_complex F).hom.app X).f (n+1) = 0 := rfl
@[simp] lemma single₀_map_homological_complex_inv_app_zero (F : V ⥤ W) [F.additive] (X : V) :
  ((single₀_map_homological_complex F).inv.app X).f 0 = 𝟙 _ := rfl
@[simp] lemma single₀_map_homological_complex_inv_app_succ
  (F : V ⥤ W) [F.additive] (X : V) (n : ℕ) :
  ((single₀_map_homological_complex F).inv.app X).f (n+1) = 0 := rfl

end cochain_complex


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

! This file was ported from Lean 3 source module order.with_bot
! leanprover-community/mathlib commit 0111834459f5d7400215223ea95ae38a1265a907
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Order.BoundedOrder
import Mathlib.Data.Option.NAry
import Mathlib.Tactic.Lift

/-!
# `WithBot`, `WithTop`

Adding a `bot` or a `top` to an order.

## Main declarations

* `With<Top/Bot> α`: Equips `Option α` with the order on `α` plus `none` as the top/bottom element.

 -/

variable {α β γ δ : Type _}

/-- Attach `⊥` to a type. -/
def WithBot (α : Type _) :=
  Option α
#align with_bot WithBot

namespace WithBot

variable {a b : α}

instance [Repr α] : Repr (WithBot α) :=
  ⟨fun o _ =>
    match o with
    | none => "⊥"
    | some a => "↑" ++ repr a⟩

/-- The canonical map from `α` into `WithBot α` -/
@[coe, match_pattern] def some : α → WithBot α :=
  Option.some

instance coeTC : CoeTC α (WithBot α) :=
  ⟨some⟩

instance bot : Bot (WithBot α) :=
  ⟨none⟩

instance inhabited : Inhabited (WithBot α) :=
  ⟨⊥⟩

instance nontrivial [Nonempty α] : Nontrivial (WithBot α) :=
  Option.nontrivial

open Function

theorem coe_injective : Injective (fun (a : α) => (a : WithBot α)) :=
  Option.some_injective _
#align with_bot.coe_injective WithBot.coe_injective

@[simp, norm_cast]
theorem coe_inj : (a : WithBot α) = b ↔ a = b :=
  Option.some_inj
#align with_bot.coe_inj WithBot.coe_inj

protected theorem «forall» {p : WithBot α → Prop} : (∀ x, p x) ↔ p ⊥ ∧ ∀ x : α, p x :=
  Option.forall
#align with_bot.forall WithBot.forall

protected theorem «exists» {p : WithBot α → Prop} : (∃ x, p x) ↔ p ⊥ ∨ ∃ x : α, p x :=
  Option.exists
#align with_bot.exists WithBot.exists

theorem none_eq_bot : (none : WithBot α) = (⊥ : WithBot α) :=
  rfl
#align with_bot.none_eq_bot WithBot.none_eq_bot

theorem some_eq_coe (a : α) : (Option.some a : WithBot α) = (↑a : WithBot α) :=
  rfl
#align with_bot.some_eq_coe WithBot.some_eq_coe

@[simp]
theorem bot_ne_coe : ⊥ ≠ (a : WithBot α) :=
  fun.
#align with_bot.bot_ne_coe WithBot.bot_ne_coe

@[simp]
theorem coe_ne_bot : (a : WithBot α) ≠ ⊥ :=
  fun.
#align with_bot.coe_ne_bot WithBot.coe_ne_bot

/-- Recursor for `WithBot` using the preferred forms `⊥` and `↑a`. -/
@[elab_as_elim]
def recBotCoe {C : WithBot α → Sort _} (bot : C ⊥) (coe : ∀ a : α, C a) : ∀ n : WithBot α, C n
| none => bot
| Option.some a => coe a
#align with_bot.rec_bot_coe WithBot.recBotCoe

@[simp]
theorem recBotCoe_bot {C : WithBot α → Sort _} (d : C ⊥) (f : ∀ a : α, C a) :
    @recBotCoe _ C d f ⊥ = d :=
  rfl
#align with_bot.rec_bot_coe_bot WithBot.recBotCoe_bot

@[simp]
theorem recBotCoe_coe {C : WithBot α → Sort _} (d : C ⊥) (f : ∀ a : α, C a) (x : α) :
    @recBotCoe _ C d f ↑x = f x :=
  rfl
#align with_bot.rec_bot_coe_coe WithBot.recBotCoe_coe

/-- Specialization of `Option.get_or_else` to values in `WithBot α` that respects API boundaries.
-/
def unbot' (d : α) (x : WithBot α) : α :=
  recBotCoe d id x
#align with_bot.unbot' WithBot.unbot'

@[simp]
theorem unbot'_bot {α} (d : α) : unbot' d ⊥ = d :=
  rfl
#align with_bot.unbot'_bot WithBot.unbot'_bot

@[simp]
theorem unbot'_coe {α} (d x : α) : unbot' d x = x :=
  rfl
#align with_bot.unbot'_coe WithBot.unbot'_coe

theorem coe_eq_coe : (a : WithBot α) = b ↔ a = b := coe_inj
#align with_bot.coe_eq_coe WithBot.coe_eq_coe

theorem unbot'_eq_iff {d y : α} {x : WithBot α} : unbot' d x = y ↔ x = y ∨ x = ⊥ ∧ y = d := by
  induction x using recBotCoe <;> simp [@eq_comm _ d]
#align with_bot.unbot'_eq_iff WithBot.unbot'_eq_iff

@[simp] theorem unbot'_eq_self_iff {d : α} {x : WithBot α} : unbot' d x = d ↔ x = d ∨ x = ⊥ := by
  simp [unbot'_eq_iff]
#align with_bot.unbot'_eq_self_iff WithBot.unbot'_eq_self_iff

theorem unbot'_eq_unbot'_iff {d : α} {x y : WithBot α} :
    unbot' d x = unbot' d y ↔ x = y ∨ x = d ∧ y = ⊥ ∨ x = ⊥ ∧ y = d := by
 induction y using recBotCoe <;> simp [unbot'_eq_iff, or_comm]
#align with_bot.unbot'_eq_unbot'_iff WithBot.unbot'_eq_unbot'_iff

/-- Lift a map `f : α → β` to `WithBot α → WithBot β`. Implemented using `Option.map`. -/
def map (f : α → β) : WithBot α → WithBot β :=
  Option.map f
#align with_bot.map WithBot.map

@[simp]
theorem map_bot (f : α → β) : map f ⊥ = ⊥ :=
  rfl
#align with_bot.map_bot WithBot.map_bot

@[simp]
theorem map_coe (f : α → β) (a : α) : map f a = f a :=
  rfl
#align with_bot.map_coe WithBot.map_coe

theorem map_comm {f₁ : α → β} {f₂ : α → γ} {g₁ : β → δ} {g₂ : γ → δ}
    (h : g₁ ∘ f₁ = g₂ ∘ f₂) (a : α) :
    map g₁ (map f₁ a) = map g₂ (map f₂ a) :=
  Option.map_comm h _
#align with_bot.map_comm WithBot.map_comm

theorem ne_bot_iff_exists {x : WithBot α} : x ≠ ⊥ ↔ ∃ a : α, ↑a = x :=
  Option.ne_none_iff_exists
#align with_bot.ne_bot_iff_exists WithBot.ne_bot_iff_exists

/-- Deconstruct a `x : WithBot α` to the underlying value in `α`, given a proof that `x ≠ ⊥`. -/
def unbot : ∀ x : WithBot α, x ≠ ⊥ → α
  | ⊥, h => absurd rfl h
  | Option.some x, _ => x
#align with_bot.unbot WithBot.unbot

@[simp]
theorem coe_unbot (x : WithBot α) (h : x ≠ ⊥) : (x.unbot h : WithBot α) = x := by
  cases x
  exact (h rfl).elim
  rfl
#align with_bot.coe_unbot WithBot.coe_unbot

@[simp]
theorem unbot_coe (x : α) (h : (x : WithBot α) ≠ ⊥ := coe_ne_bot) : (x : WithBot α).unbot h = x :=
  rfl
#align with_bot.unbot_coe WithBot.unbot_coe

instance canLift : CanLift (WithBot α) α (↑) fun r => r ≠ ⊥ where
  prf x h := ⟨x.unbot h, coe_unbot _ _⟩
#align with_bot.can_lift WithBot.canLift

section LE

variable [LE α]

instance (priority := 10) le : LE (WithBot α) :=
  ⟨fun o₁ o₂ : Option α => ∀ a ∈ o₁, ∃ b ∈ o₂, a ≤ b⟩

@[simp]
theorem some_le_some : @LE.le (WithBot α) _ (Option.some a) (Option.some b) ↔ a ≤ b :=
  by simp [LE.le]
#align with_bot.some_le_some WithBot.some_le_some

@[simp, norm_cast]
theorem coe_le_coe : (a : WithBot α) ≤ b ↔ a ≤ b :=
  some_le_some
#align with_bot.coe_le_coe WithBot.coe_le_coe

@[simp]
theorem none_le {a : WithBot α} : @LE.le (WithBot α) _ none a := fun _ h => Option.noConfusion h
#align with_bot.none_le WithBot.none_le

instance orderBot : OrderBot (WithBot α) :=
  { WithBot.bot with bot_le := fun _ => none_le }

instance orderTop [OrderTop α] : OrderTop (WithBot α) where
  top := some ⊤
  le_top o a ha := by cases ha ; exact ⟨_, rfl, le_top⟩

instance [OrderTop α] : BoundedOrder (WithBot α) :=
  { WithBot.orderBot, WithBot.orderTop with }

theorem not_coe_le_bot (a : α) : ¬(a : WithBot α) ≤ ⊥ := fun h =>
  let ⟨_, hb, _⟩ := h _ rfl
  Option.not_mem_none _ hb
#align with_bot.not_coe_le_bot WithBot.not_coe_le_bot

theorem coe_le : ∀ {o : Option α}, b ∈ o → ((a : WithBot α) ≤ o ↔ a ≤ b)
  | _, rfl => coe_le_coe
#align with_bot.coe_le WithBot.coe_le

theorem coe_le_iff : ∀ {x : WithBot α}, (a : WithBot α) ≤ x ↔ ∃ b : α, x = b ∧ a ≤ b
  | Option.some x => by simp [some_eq_coe]
  | none => iff_of_false (not_coe_le_bot _) <| by simp [none_eq_bot]
#align with_bot.coe_le_iff WithBot.coe_le_iff

theorem le_coe_iff : ∀ {x : WithBot α}, x ≤ b ↔ ∀ a : α, x = ↑a → a ≤ b
  | Option.some b => by simp [some_eq_coe, coe_eq_coe]
  | none => by simp [none_eq_bot]
#align with_bot.le_coe_iff WithBot.le_coe_iff

protected theorem _root_.IsMax.withBot (h : IsMax a) : IsMax (a : WithBot α)
  | none, _ => bot_le
  | Option.some _, hb => some_le_some.2 <| h <| some_le_some.1 hb
#align is_max.with_bot IsMax.withBot

end LE

section LT

variable [LT α]

instance (priority := 10) lt : LT (WithBot α) :=
  ⟨fun o₁ o₂ : Option α => ∃ b ∈ o₂, ∀ a ∈ o₁, a < b⟩

@[simp]
theorem some_lt_some : @LT.lt (WithBot α) _ (Option.some a) (Option.some b) ↔ a < b := by
  simp [LT.lt]
#align with_bot.some_lt_some WithBot.some_lt_some

@[simp, norm_cast]
theorem coe_lt_coe : (a : WithBot α) < b ↔ a < b :=
  some_lt_some
#align with_bot.coe_lt_coe WithBot.coe_lt_coe

@[simp]
theorem none_lt_some (a : α) : @LT.lt (WithBot α) _ none (some a) :=
  ⟨a, rfl, fun _ hb => (Option.not_mem_none _ hb).elim⟩
#align with_bot.none_lt_some WithBot.none_lt_some

theorem bot_lt_coe (a : α) : (⊥ : WithBot α) < a :=
  none_lt_some a
#align with_bot.bot_lt_coe WithBot.bot_lt_coe

@[simp]
theorem not_lt_none (a : WithBot α) : ¬@LT.lt (WithBot α) _ a none :=
  fun ⟨_, h, _⟩ => Option.not_mem_none _ h
#align with_bot.not_lt_none WithBot.not_lt_none

theorem lt_iff_exists_coe : ∀ {a b : WithBot α}, a < b ↔ ∃ p : α, b = p ∧ a < p
  | a, Option.some b => by simp [some_eq_coe, coe_eq_coe]
  | a, none => iff_of_false (not_lt_none _) <| by simp [none_eq_bot]
#align with_bot.lt_iff_exists_coe WithBot.lt_iff_exists_coe

theorem lt_coe_iff : ∀ {x : WithBot α}, x < b ↔ ∀ a, x = ↑a → a < b
  | Option.some b => by simp [some_eq_coe, coe_eq_coe, coe_lt_coe]
  | none => by simp [none_eq_bot, bot_lt_coe]
#align with_bot.lt_coe_iff WithBot.lt_coe_iff

/-- A version of `bot_lt_iff_ne_bot` for `WithBot` that only requires `LT α`, not
`PartialOrder α`. -/
protected

end LT

instance preorder [Preorder α] : Preorder (WithBot α) where
  le := (· ≤ ·)
  lt := (· < ·)
  lt_iff_le_not_le := by
    intros a b
    cases a <;> cases b <;> simp [lt_iff_le_not_le] ; simp [LE.le, LT.lt]
  le_refl o a ha := ⟨a, ha, le_rfl⟩
  le_trans o₁ o₂ o₃ h₁ h₂ a ha :=
    let ⟨b, hb, ab⟩ := h₁ a ha
    let ⟨c, hc, bc⟩ := h₂ b hb
    ⟨c, hc, le_trans ab bc⟩

instance partialOrder [PartialOrder α] : PartialOrder (WithBot α) :=
  { WithBot.preorder with
    le_antisymm := fun o₁ o₂ h₁ h₂ => by
      cases' o₁ with a
      · cases' o₂ with b
        · rfl

        rcases h₂ b rfl with ⟨_, ⟨⟩, _⟩

      · rcases h₁ a rfl with ⟨b, ⟨⟩, h₁'⟩
        rcases h₂ b rfl with ⟨_, ⟨⟩, h₂'⟩
        rw [le_antisymm h₁' h₂']
         }
#align with_bot.partial_order WithBot.partialOrder

theorem coe_strictMono [Preorder α] : StrictMono (fun (a : α) => (a : WithBot α)) :=
  fun _ _ => coe_lt_coe.2
#align with_bot.coe_strict_mono WithBot.coe_strictMono

theorem coe_mono [Preorder α] : Monotone (fun (a : α) => (a : WithBot α)) :=
  fun _ _ => coe_le_coe.2
#align with_bot.coe_mono WithBot.coe_mono

theorem monotone_iff [Preorder α] [Preorder β] {f : WithBot α → β} :
    Monotone f ↔ Monotone (λ a => f a : α → β) ∧ ∀ x : α, f ⊥ ≤ f x :=
  ⟨fun h => ⟨h.comp WithBot.coe_mono, fun _ => h bot_le⟩, fun h =>
    WithBot.forall.2
      ⟨WithBot.forall.2 ⟨fun _ => le_rfl, fun x _ => h.2 x⟩, fun _ =>
        WithBot.forall.2 ⟨fun h => (not_coe_le_bot _ h).elim,
          fun _ hle => h.1 (coe_le_coe.1 hle)⟩⟩⟩
#align with_bot.monotone_iff WithBot.monotone_iff

@[simp]
theorem monotone_map_iff [Preorder α] [Preorder β] {f : α → β} :
    Monotone (WithBot.map f) ↔ Monotone f :=
  monotone_iff.trans <| by simp [Monotone]
#align with_bot.monotone_map_iff WithBot.monotone_map_iff

alias monotone_map_iff ↔ _ _root_.Monotone.withBot_map
#align monotone.with_bot_map Monotone.withBot_map

theorem strictMono_iff [Preorder α] [Preorder β] {f : WithBot α → β} :
    StrictMono f ↔ StrictMono (λ a => f a : α → β) ∧ ∀ x : α, f ⊥ < f x :=
  ⟨fun h => ⟨h.comp WithBot.coe_strictMono, fun _ => h (bot_lt_coe _)⟩, fun h =>
    WithBot.forall.2
      ⟨WithBot.forall.2 ⟨flip absurd (lt_irrefl _), fun x _ => h.2 x⟩, fun _ =>
        WithBot.forall.2 ⟨fun h => (not_lt_bot h).elim, fun _ hle => h.1 (coe_lt_coe.1 hle)⟩⟩⟩
#align with_bot.strict_mono_iff WithBot.strictMono_iff

theorem strictAnti_iff [Preorder α] [Preorder β] {f : WithBot α → β} :
    StrictAnti f ↔ StrictAnti (λ a => f a : α → β) ∧ ∀ x : α, f x < f ⊥ :=
  strictMono_iff (β := βᵒᵈ)

@[simp]
theorem strictMono_map_iff [Preorder α] [Preorder β] {f : α → β} :
    StrictMono (WithBot.map f) ↔ StrictMono f :=
  strictMono_iff.trans <| by simp [StrictMono, bot_lt_coe]
#align with_bot.strict_mono_map_iff WithBot.strictMono_map_iff

alias strictMono_map_iff ↔ _ _root_.StrictMono.withBot_map
#align strict_mono.with_bot_map StrictMono.withBot_map

theorem map_le_iff [Preorder α] [Preorder β] (f : α → β) (mono_iff : ∀ {a b}, f a ≤ f b ↔ a ≤ b) :
    ∀ a b : WithBot α, a.map f ≤ b.map f ↔ a ≤ b
  | ⊥, _ => by simp only [map_bot, bot_le]
  | (a : α), ⊥ => by simp only [map_coe, map_bot, coe_ne_bot, not_coe_le_bot _]
  | (a : α), (b : α) => by simpa only [map_coe, coe_le_coe] using mono_iff
#align with_bot.map_le_iff WithBot.map_le_iff

theorem le_coe_unbot' [Preorder α] : ∀ (a : WithBot α) (b : α), a ≤ a.unbot' b
  | (a : α), _ => le_rfl
  | ⊥, _ => bot_le
#align with_bot.le_coe_unbot' WithBot.le_coe_unbot'

theorem unbot'_bot_le_iff [LE α] [OrderBot α] {a : WithBot α} {b : α} :
    a.unbot' ⊥ ≤ b ↔ a ≤ b := by
  cases a <;> simp [none_eq_bot, some_eq_coe]
#align with_bot.unbot'_bot_le_iff WithBot.unbot'_bot_le_iff

theorem unbot'_lt_iff [LT α] {a : WithBot α} {b c : α} (ha : a ≠ ⊥) : a.unbot' b < c ↔ a < c := by
  cases a
  · exact (ha rfl).elim
  . rw [some_eq_coe, unbot'_coe, coe_lt_coe]
#align with_bot.unbot'_lt_iff WithBot.unbot'_lt_iff

instance semilatticeSup [SemilatticeSup α] : SemilatticeSup (WithBot α) :=
  { WithBot.partialOrder, @WithBot.orderBot α _ with
    sup := Option.liftOrGet (· ⊔ ·),
    le_sup_left := fun o₁ o₂ a ha => by cases ha ; cases o₂ <;> simp [Option.liftOrGet],
    le_sup_right := fun o₁ o₂ a ha => by cases ha ; cases o₁ <;> simp [Option.liftOrGet],
    sup_le := fun o₁ o₂ o₃ h₁ h₂ a ha => by
      cases' o₁ with b <;> cases' o₂ with c <;> cases ha
      · exact h₂ a rfl

      · exact h₁ a rfl

      · rcases h₁ b rfl with ⟨d, ⟨⟩, h₁'⟩
        simp at h₂
        exact ⟨d, rfl, sup_le h₁' h₂⟩
         }

theorem coe_sup [SemilatticeSup α] (a b : α) : ((a ⊔ b : α) : WithBot α) = (a : WithBot α) ⊔ b :=
  rfl
#align with_bot.coe_sup WithBot.coe_sup

instance semilatticeInf [SemilatticeInf α] : SemilatticeInf (WithBot α) :=
  { WithBot.partialOrder, @WithBot.orderBot α _ with
    inf := Option.map₂ (· ⊓ ·),
    inf_le_left := fun o₁ o₂ a ha => by
      rcases Option.mem_map₂_iff.1 ha with ⟨a, b, (rfl : _ = _), (rfl : _ = _), rfl⟩
      exact ⟨_, rfl, inf_le_left⟩,
    inf_le_right := fun o₁ o₂ a ha => by
      rcases Option.mem_map₂_iff.1 ha with ⟨a, b, (rfl : _ = _), (rfl : _ = _), rfl⟩
      exact ⟨_, rfl, inf_le_right⟩,
    le_inf := fun o₁ o₂ o₃ h₁ h₂ a ha => by
      cases ha
      rcases h₁ a rfl with ⟨b, ⟨⟩, ab⟩
      rcases h₂ a rfl with ⟨c, ⟨⟩, ac⟩
      exact ⟨_, rfl, le_inf ab ac⟩ }

theorem coe_inf [SemilatticeInf α] (a b : α) : ((a ⊓ b : α) : WithBot α) = (a : WithBot α) ⊓ b :=
  rfl
#align with_bot.coe_inf WithBot.coe_inf

instance lattice [Lattice α] : Lattice (WithBot α) :=
  { WithBot.semilatticeSup, WithBot.semilatticeInf with }

instance distribLattice [DistribLattice α] : DistribLattice (WithBot α) :=
  { WithBot.lattice with
    le_sup_inf := fun o₁ o₂ o₃ =>
      match o₁, o₂, o₃ with
      | ⊥, ⊥, ⊥ => le_rfl
      | ⊥, ⊥, (a₁ : α) => le_rfl
      | ⊥, (a₁ : α), ⊥ => le_rfl
      | ⊥, (a₁ : α), (a₃ : α) => le_rfl
      | (a₁ : α), ⊥, ⊥ => inf_le_left
      | (a₁ : α), ⊥, (a₃ : α) => inf_le_left
      | (a₁ : α), (a₂ : α), ⊥ => inf_le_right
      | (a₁ : α), (a₂ : α), (a₃ : α) => coe_le_coe.mpr le_sup_inf }

instance decidableLE [LE α] [@DecidableRel α (· ≤ ·)] : @DecidableRel (WithBot α) (· ≤ ·)
  | none, x => isTrue fun a h => Option.noConfusion h
  | Option.some x, Option.some y =>
      if h : x ≤ y then isTrue (some_le_some.2 h) else isFalse <| by simp [*]
  | Option.some x, none => isFalse fun h => by rcases h x rfl with ⟨y, ⟨_⟩, _⟩
#align with_bot.decidable_le WithBot.decidableLE

instance decidableLT [LT α] [@DecidableRel α (· < ·)] : @DecidableRel (WithBot α) (· < ·)
  | none, Option.some x => isTrue <| by exists x, rfl ; rintro _ ⟨⟩
  | Option.some x, Option.some y =>
      if h : x < y then isTrue <| by simp [*] else isFalse <| by simp [*]
  | x, none => isFalse <| by rintro ⟨a, ⟨⟨⟩⟩⟩
#align with_bot.decidable_lt WithBot.decidableLT

instance isTotal_le [LE α] [IsTotal α (· ≤ ·)] : IsTotal (WithBot α) (· ≤ ·) :=
  ⟨fun a b =>
    match a, b with
    | none, _ => Or.inl bot_le
    | _, none => Or.inr bot_le
    | Option.some x, Option.some y => (total_of (· ≤ ·) x y).imp some_le_some.2 some_le_some.2⟩
#align with_bot.is_total_le WithBot.isTotal_le

instance linearOrder [LinearOrder α] : LinearOrder (WithBot α) :=
  Lattice.toLinearOrder _
#align with_bot.linear_order WithBot.linearOrder

@[simp, norm_cast]
theorem coe_min [LinearOrder α] (x y : α) : ((min x y : α) : WithBot α) = min (x : WithBot α) y :=
  rfl
#align with_bot.coe_min WithBot.coe_min

@[simp, norm_cast]
theorem coe_max [LinearOrder α] (x y : α) : ((max x y : α) : WithBot α) = max (x : WithBot α) y :=
  rfl
#align with_bot.coe_max WithBot.coe_max

theorem wellFounded_lt [Preorder α] (h : @WellFounded α (· < ·)) :
    @WellFounded (WithBot α) (· < ·) :=
  have acc_bot : Acc ((· < ·) : WithBot α → WithBot α → Prop) ⊥ :=
    Acc.intro _ fun _ ha => (not_le_of_gt ha bot_le).elim
  ⟨fun a =>
    Option.recOn a acc_bot fun a =>
      Acc.intro _ fun b =>
        Option.recOn b (fun _ => acc_bot) fun b =>
          WellFounded.induction h b
            (show
              ∀ b : α,
                (∀ c, c < b → (c : WithBot α) < a → Acc
                    ((· < ·) : WithBot α → WithBot α → Prop) c) →
                  (b : WithBot α) < a → Acc ((· < ·) : WithBot α → WithBot α → Prop) b
              from fun _ ih hba =>
              Acc.intro _ fun c =>
                Option.recOn c (fun _ => acc_bot) fun _ hc => ih _
                  (some_lt_some.1 hc) (lt_trans hc hba))⟩
#align with_bot.well_founded_lt WithBot.wellFounded_lt

instance denselyOrdered [LT α] [DenselyOrdered α] [NoMinOrder α] : DenselyOrdered (WithBot α) :=
  ⟨fun a b =>
    match a, b with
    | a, none => fun h : a < ⊥ => (not_lt_none _ h).elim
    | none, Option.some b => fun _ =>
      let ⟨a, ha⟩ := exists_lt b
      ⟨a, bot_lt_coe a, coe_lt_coe.2 ha⟩
    | Option.some _, Option.some _ => fun h =>
      let ⟨a, ha₁, ha₂⟩ := exists_between (coe_lt_coe.1 h)
      ⟨a, coe_lt_coe.2 ha₁, coe_lt_coe.2 ha₂⟩⟩

theorem lt_iff_exists_coe_btwn [Preorder α] [DenselyOrdered α] [NoMinOrder α] {a b : WithBot α} :
    a < b ↔ ∃ x : α, a < ↑x ∧ ↑x < b :=
  ⟨fun h =>
    let ⟨_, hy⟩ := exists_between h
    let ⟨x, hx⟩ := lt_iff_exists_coe.1 hy.1
    ⟨x, hx.1 ▸ hy⟩,
    fun ⟨_, hx⟩ => lt_trans hx.1 hx.2⟩
#align with_bot.lt_iff_exists_coe_btwn WithBot.lt_iff_exists_coe_btwn

instance noTopOrder [LE α] [NoTopOrder α] [Nonempty α] : NoTopOrder (WithBot α) :=
  ⟨by
    apply recBotCoe
    · exact ‹Nonempty α›.elim fun a => ⟨a, not_coe_le_bot a⟩

    · intro a
      obtain ⟨b, h⟩ := exists_not_le a
      exact ⟨b, by rwa [coe_le_coe]⟩
      ⟩

instance noMaxOrder [LT α] [NoMaxOrder α] [Nonempty α] : NoMaxOrder (WithBot α) :=
  ⟨by
    apply WithBot.recBotCoe
    · apply ‹Nonempty α›.elim
      exact fun a => ⟨a, WithBot.bot_lt_coe a⟩

    · intro a
      obtain ⟨b, ha⟩ := exists_gt a
      exact ⟨b, coe_lt_coe.mpr ha⟩
      ⟩

end WithBot

--TODO(Mario): Construct using order dual on `WithBot`
/-- Attach `⊤` to a type. -/
def WithTop (α : Type _) :=
  Option α
#align with_top WithTop

namespace WithTop

variable {a b : α}

instance [Repr α] : Repr (WithTop α) :=
  ⟨fun o _ =>
    match o with
    | none => "⊤"
    | some a => "↑" ++ repr a⟩

/-- The canonical map from `α` into `WithTop α` -/
@[coe, match_pattern] def some : α → WithTop α :=
  Option.some

instance coeTC : CoeTC α (WithTop α) :=
  ⟨some⟩

instance top : Top (WithTop α) :=
  ⟨none⟩

instance inhabited : Inhabited (WithTop α) :=
  ⟨⊤⟩

instance nontrivial [Nonempty α] : Nontrivial (WithTop α) :=
  Option.nontrivial

protected theorem «forall» {p : WithTop α → Prop} : (∀ x, p x) ↔ p ⊤ ∧ ∀ x : α, p x :=
  Option.forall
#align with_top.forall WithTop.forall

protected theorem «exists» {p : WithTop α → Prop} : (∃ x, p x) ↔ p ⊤ ∨ ∃ x : α, p x :=
  Option.exists
#align with_top.exists WithTop.exists

theorem none_eq_top : (none : WithTop α) = (⊤ : WithTop α) :=
  rfl
#align with_top.none_eq_top WithTop.none_eq_top

theorem some_eq_coe (a : α) : (Option.some a : WithTop α) = (↑a : WithTop α) :=
  rfl
#align with_top.some_eq_coe WithTop.some_eq_coe

@[simp]
theorem top_ne_coe : ⊤ ≠ (a : WithTop α) :=
  fun.
#align with_top.top_ne_coe WithTop.top_ne_coe

@[simp]
theorem coe_ne_top : (a : WithTop α) ≠ ⊤ :=
  fun.
#align with_top.coe_ne_top WithTop.coe_ne_top

/-- Recursor for `WithTop` using the preferred forms `⊤` and `↑a`. -/
@[elab_as_elim]
def recTopCoe {C : WithTop α → Sort _} (top : C ⊤) (coe : ∀ a : α, C a) : ∀ n : WithTop α, C n
| none => top
| Option.some a => coe a
#align with_top.rec_top_coe WithTop.recTopCoe

@[simp]
theorem recTopCoe_top {C : WithTop α → Sort _} (d : C ⊤) (f : ∀ a : α, C a) :
    @recTopCoe _ C d f ⊤ = d :=
  rfl
#align with_top.rec_top_coe_top WithTop.recTopCoe_top

@[simp]
theorem recTopCoe_coe {C : WithTop α → Sort _} (d : C ⊤) (f : ∀ a : α, C a) (x : α) :
    @recTopCoe _ C d f ↑x = f x :=
  rfl
#align with_top.rec_top_coe_coe WithTop.recTopCoe_coe

/-- `WithTop.toDual` is the equivalence sending `⊤` to `⊥` and any `a : α` to `toDual a : αᵒᵈ`.
See `WithTop.toDualBotEquiv` for the related order-iso.
-/
protected def toDual : WithTop α ≃ WithBot αᵒᵈ :=
  Equiv.refl _
#align with_top.to_dual WithTop.toDual

/-- `WithTop.ofDual` is the equivalence sending `⊤` to `⊥` and any `a : αᵒᵈ` to `ofDual a : α`.
See `WithTop.toDualBotEquiv` for the related order-iso.
-/
protected def ofDual : WithTop αᵒᵈ ≃ WithBot α :=
  Equiv.refl _
#align with_top.of_dual WithTop.ofDual

/-- `WithBot.toDual` is the equivalence sending `⊥` to `⊤` and any `a : α` to `toDual a : αᵒᵈ`.
See `WithBot.toDual_top_equiv` for the related order-iso.
-/
protected def _root_.WithBot.toDual : WithBot α ≃ WithTop αᵒᵈ :=
  Equiv.refl _
#align with_bot.to_dual WithBot.toDual

/-- `WithBot.ofDual` is the equivalence sending `⊥` to `⊤` and any `a : αᵒᵈ` to `ofDual a : α`.
See `WithBot.ofDual_top_equiv` for the related order-iso.
-/
protected def _root_.WithBot.ofDual : WithBot αᵒᵈ ≃ WithTop α :=
  Equiv.refl _
#align with_bot.of_dual WithBot.ofDual

@[simp]
theorem toDual_symm_apply (a : WithBot αᵒᵈ) : WithTop.toDual.symm a = WithBot.ofDual a :=
  rfl
#align with_top.to_dual_symm_apply WithTop.toDual_symm_apply

@[simp]
theorem ofDual_symm_apply (a : WithBot α) : WithTop.ofDual.symm a = WithBot.toDual a :=
  rfl
#align with_top.of_dual_symm_apply WithTop.ofDual_symm_apply

@[simp]
theorem toDual_apply_top : WithTop.toDual (⊤ : WithTop α) = ⊥ :=
  rfl
#align with_top.to_dual_apply_top WithTop.toDual_apply_top

@[simp]
theorem ofDual_apply_top : WithTop.ofDual (⊤ : WithTop α) = ⊥ :=
  rfl
#align with_top.of_dual_apply_top WithTop.ofDual_apply_top

open OrderDual

@[simp]
theorem toDual_apply_coe (a : α) : WithTop.toDual (a : WithTop α) = toDual a :=
  rfl
#align with_top.to_dual_apply_coe WithTop.toDual_apply_coe

@[simp]
theorem ofDual_apply_coe (a : αᵒᵈ) : WithTop.ofDual (a : WithTop αᵒᵈ) = ofDual a :=
  rfl
#align with_top.of_dual_apply_coe WithTop.ofDual_apply_coe

/-- Specialization of `Option.get_or_else` to values in `WithTop α` that respects API boundaries.
-/
def untop' (d : α) (x : WithTop α) : α :=
  recTopCoe d id x
#align with_top.untop' WithTop.untop'

@[simp]
theorem untop'_top {α} (d : α) : untop' d ⊤ = d :=
  rfl
#align with_top.untop'_top WithTop.untop'_top

@[simp]
theorem untop'_coe {α} (d x : α) : untop' d x = x :=
  rfl
#align with_top.untop'_coe WithTop.untop'_coe

@[simp, norm_cast] -- porting note: added `simp`
theorem coe_eq_coe : (a : WithTop α) = b ↔ a = b :=
  Option.some_inj
#align with_top.coe_eq_coe WithTop.coe_eq_coe

theorem untop'_eq_iff {d y : α} {x : WithTop α} : untop' d x = y ↔ x = y ∨ x = ⊤ ∧ y = d :=
  WithBot.unbot'_eq_iff
#align with_top.untop'_eq_iff WithTop.untop'_eq_iff

@[simp] theorem untop'_eq_self_iff {d : α} {x : WithTop α} : untop' d x = d ↔ x = d ∨ x = ⊤ :=
  WithBot.unbot'_eq_self_iff
#align with_top.untop'_eq_self_iff WithTop.untop'_eq_self_iff

theorem untop'_eq_untop'_iff {d : α} {x y : WithTop α} :
    untop' d x = untop' d y ↔ x = y ∨ x = d ∧ y = ⊤ ∨ x = ⊤ ∧ y = d :=
  WithBot.unbot'_eq_unbot'_iff
#align with_top.untop'_eq_untop'_iff WithTop.untop'_eq_untop'_iff

/-- Lift a map `f : α → β` to `WithTop α → WithTop β`. Implemented using `Option.map`. -/
def map (f : α → β) : WithTop α → WithTop β :=
  Option.map f
#align with_top.map WithTop.map

@[simp]
theorem map_top (f : α → β) : map f ⊤ = ⊤ :=
  rfl
#align with_top.map_top WithTop.map_top

@[simp]
theorem map_coe (f : α → β) (a : α) : map f a = f a :=
  rfl
#align with_top.map_coe WithTop.map_coe

theorem map_comm {f₁ : α → β} {f₂ : α → γ} {g₁ : β → δ} {g₂ : γ → δ}
    (h : g₁ ∘ f₁ = g₂ ∘ f₂) (a : α) : map g₁ (map f₁ a) = map g₂ (map f₂ a) :=
  Option.map_comm h _
#align with_top.map_comm WithTop.map_comm

theorem map_toDual (f : αᵒᵈ → βᵒᵈ) (a : WithBot α) :
    map f (WithBot.toDual a) = a.map (toDual ∘ f) :=
  rfl
#align with_top.map_to_dual WithTop.map_toDual

theorem map_ofDual (f : α → β) (a : WithBot αᵒᵈ) : map f (WithBot.ofDual a) = a.map (ofDual ∘ f) :=
  rfl
#align with_top.map_of_dual WithTop.map_ofDual

theorem toDual_map (f : α → β) (a : WithTop α) :
    WithTop.toDual (map f a) = WithBot.map (toDual ∘ f ∘ ofDual) (WithTop.toDual a) :=
  rfl
#align with_top.to_dual_map WithTop.toDual_map

theorem ofDual_map (f : αᵒᵈ → βᵒᵈ) (a : WithTop αᵒᵈ) :
    WithTop.ofDual (map f a) = WithBot.map (ofDual ∘ f ∘ toDual) (WithTop.ofDual a) :=
  rfl
#align with_top.of_dual_map WithTop.ofDual_map

theorem ne_top_iff_exists {x : WithTop α} : x ≠ ⊤ ↔ ∃ a : α, ↑a = x :=
  Option.ne_none_iff_exists
#align with_top.ne_top_iff_exists WithTop.ne_top_iff_exists

/-- Deconstruct a `x : WithTop α` to the underlying value in `α`, given a proof that `x ≠ ⊤`. -/
def untop : ∀ x : WithTop α, x ≠ ⊤ → α :=
  WithBot.unbot
#align with_top.untop WithTop.untop

@[simp]
theorem coe_untop (x : WithTop α) (h : x ≠ ⊤) : (x.untop h : WithTop α) = x :=
  WithBot.coe_unbot x h
#align with_top.coe_untop WithTop.coe_untop

@[simp]
theorem untop_coe (x : α) (h : (x : WithTop α) ≠ ⊤ := coe_ne_top) : (x : WithTop α).untop h = x :=
  rfl
#align with_top.untop_coe WithTop.untop_coe

instance canLift : CanLift (WithTop α) α (↑) fun r => r ≠ ⊤ where
  prf x h := ⟨x.untop h, coe_untop _ _⟩
#align with_top.can_lift WithTop.canLift

section LE

variable [LE α]

instance (priority := 10) le : LE (WithTop α) :=
  ⟨fun o₁ o₂ : Option α => ∀ a ∈ o₂, ∃ b ∈ o₁, b ≤ a⟩

theorem toDual_le_iff {a : WithTop α} {b : WithBot αᵒᵈ} :
    WithTop.toDual a ≤ b ↔ WithBot.ofDual b ≤ a :=
  Iff.rfl
#align with_top.to_dual_le_iff WithTop.toDual_le_iff

theorem le_toDual_iff {a : WithBot αᵒᵈ} {b : WithTop α} :
    a ≤ WithTop.toDual b ↔ b ≤ WithBot.ofDual a :=
  Iff.rfl
#align with_top.le_to_dual_iff WithTop.le_toDual_iff

@[simp]
theorem toDual_le_toDual_iff {a b : WithTop α} : WithTop.toDual a ≤ WithTop.toDual b ↔ b ≤ a :=
  Iff.rfl
#align with_top.to_dual_le_to_dual_iff WithTop.toDual_le_toDual_iff

theorem ofDual_le_iff {a : WithTop αᵒᵈ} {b : WithBot α} :
    WithTop.ofDual a ≤ b ↔ WithBot.toDual b ≤ a :=
  Iff.rfl
#align with_top.of_dual_le_iff WithTop.ofDual_le_iff

theorem le_ofDual_iff {a : WithBot α} {b : WithTop αᵒᵈ} :
    a ≤ WithTop.ofDual b ↔ b ≤ WithBot.toDual a :=
  Iff.rfl
#align with_top.le_of_dual_iff WithTop.le_ofDual_iff

@[simp]
theorem ofDual_le_ofDual_iff {a b : WithTop αᵒᵈ} : WithTop.ofDual a ≤ WithTop.ofDual b ↔ b ≤ a :=
  Iff.rfl
#align with_top.of_dual_le_of_dual_iff WithTop.ofDual_le_ofDual_iff

@[simp, norm_cast]
theorem coe_le_coe : (a : WithTop α) ≤ b ↔ a ≤ b := by
  simp only [← toDual_le_toDual_iff, toDual_apply_coe, WithBot.coe_le_coe, toDual_le_toDual]
#align with_top.coe_le_coe WithTop.coe_le_coe

@[simp]
theorem some_le_some : @LE.le (WithTop α) _ (Option.some a) (Option.some b) ↔ a ≤ b :=
  coe_le_coe
#align with_top.some_le_some WithTop.some_le_some

@[simp]
theorem le_none {a : WithTop α} : @LE.le (WithTop α) _ a none :=
  toDual_le_toDual_iff.mp (@WithBot.none_le αᵒᵈ _ _)
#align with_top.le_none WithTop.le_none

instance orderTop : OrderTop (WithTop α) :=
  { WithTop.top with le_top := fun _ => le_none }

instance orderBot [OrderBot α] : OrderBot (WithTop α) where
  bot := some ⊥
  bot_le o a ha := by cases ha ; exact ⟨_, rfl, bot_le⟩
#align with_top.order_bot WithTop.orderBot

instance boundedOrder [OrderBot α] : BoundedOrder (WithTop α) :=
  { WithTop.orderTop, WithTop.orderBot with }

theorem not_top_le_coe (a : α) : ¬(⊤ : WithTop α) ≤ ↑a :=
  WithBot.not_coe_le_bot (toDual a)
#align with_top.not_top_le_coe WithTop.not_top_le_coe

theorem le_coe : ∀ {o : Option α}, a ∈ o → (@LE.le (WithTop α) _ o b ↔ a ≤ b)
  | _, rfl => coe_le_coe
#align with_top.le_coe WithTop.le_coe

theorem le_coe_iff {x : WithTop α} : x ≤ b ↔ ∃ a : α, x = a ∧ a ≤ b :=
  @WithBot.coe_le_iff (αᵒᵈ) _ _ (toDual x)
#align with_top.le_coe_iff WithTop.le_coe_iff

theorem coe_le_iff {x : WithTop α} : ↑a ≤ x ↔ ∀ b : α, x = ↑b → a ≤ b :=
  @WithBot.le_coe_iff (αᵒᵈ) _ _ (toDual x)
#align with_top.coe_le_iff WithTop.coe_le_iff

protected theorem _root_.IsMin.withTop (h : IsMin a) : IsMin (a : WithTop α) := by
  -- defeq to is_max_to_dual_iff.mp (is_max.with_bot _), but that breaks API boundary
  intro _ hb
  rw [← toDual_le_toDual_iff] at hb
  simpa [toDual_le_iff] using (IsMax.withBot h : IsMax (toDual a : WithBot αᵒᵈ)) hb
#align is_min.with_top IsMin.withTop

end LE

section LT

variable [LT α]

instance (priority := 10) lt : LT (WithTop α) :=
  ⟨fun o₁ o₂ : Option α => ∃ b ∈ o₁, ∀ a ∈ o₂, b < a⟩

theorem toDual_lt_iff {a : WithTop α} {b : WithBot αᵒᵈ} :
    WithTop.toDual a < b ↔ WithBot.ofDual b < a :=
  Iff.rfl
#align with_top.to_dual_lt_iff WithTop.toDual_lt_iff

theorem lt_toDual_iff {a : WithBot αᵒᵈ} {b : WithTop α} :
    a < WithTop.toDual b ↔ b < WithBot.ofDual a :=
  Iff.rfl
#align with_top.lt_to_dual_iff WithTop.lt_toDual_iff

@[simp]
theorem toDual_lt_toDual_iff {a b : WithTop α} : WithTop.toDual a < WithTop.toDual b ↔ b < a :=
  Iff.rfl
#align with_top.to_dual_lt_to_dual_iff WithTop.toDual_lt_toDual_iff

theorem ofDual_lt_iff {a : WithTop αᵒᵈ} {b : WithBot α} :
    WithTop.ofDual a < b ↔ WithBot.toDual b < a :=
  Iff.rfl
#align with_top.of_dual_lt_iff WithTop.ofDual_lt_iff

theorem lt_ofDual_iff {a : WithBot α} {b : WithTop αᵒᵈ} :
    a < WithTop.ofDual b ↔ b < WithBot.toDual a :=
  Iff.rfl
#align with_top.lt_of_dual_iff WithTop.lt_ofDual_iff

@[simp]
theorem ofDual_lt_ofDual_iff {a b : WithTop αᵒᵈ} : WithTop.ofDual a < WithTop.ofDual b ↔ b < a :=
  Iff.rfl
#align with_top.of_dual_lt_of_dual_iff WithTop.ofDual_lt_ofDual_iff

end LT

end WithTop

namespace WithBot

open OrderDual

@[simp]
theorem toDual_symm_apply (a : WithTop αᵒᵈ) : WithBot.toDual.symm a = WithTop.ofDual a :=
  rfl
#align with_bot.to_dual_symm_apply WithBot.toDual_symm_apply

@[simp]
theorem ofDual_symm_apply (a : WithTop α) : WithBot.ofDual.symm a = WithTop.toDual a :=
  rfl
#align with_bot.of_dual_symm_apply WithBot.ofDual_symm_apply

@[simp]
theorem toDual_apply_bot : WithBot.toDual (⊥ : WithBot α) = ⊤ :=
  rfl
#align with_bot.to_dual_apply_bot WithBot.toDual_apply_bot

@[simp]
theorem ofDual_apply_bot : WithBot.ofDual (⊥ : WithBot α) = ⊤ :=
  rfl
#align with_bot.of_dual_apply_bot WithBot.ofDual_apply_bot

@[simp]
theorem toDual_apply_coe (a : α) : WithBot.toDual (a : WithBot α) = toDual a :=
  rfl
#align with_bot.to_dual_apply_coe WithBot.toDual_apply_coe

@[simp]
theorem ofDual_apply_coe (a : αᵒᵈ) : WithBot.ofDual (a : WithBot αᵒᵈ) = ofDual a :=
  rfl
#align with_bot.of_dual_apply_coe WithBot.ofDual_apply_coe

theorem map_toDual (f : αᵒᵈ → βᵒᵈ) (a : WithTop α) :
    WithBot.map f (WithTop.toDual a) = a.map (toDual ∘ f) :=
  rfl
#align with_bot.map_to_dual WithBot.map_toDual

theorem map_ofDual (f : α → β) (a : WithTop αᵒᵈ) :
    WithBot.map f (WithTop.ofDual a) = a.map (ofDual ∘ f) :=
  rfl
#align with_bot.map_of_dual WithBot.map_ofDual

theorem toDual_map (f : α → β) (a : WithBot α) :
    WithBot.toDual (WithBot.map f a) = map (toDual ∘ f ∘ ofDual) (WithBot.toDual a) :=
  rfl
#align with_bot.to_dual_map WithBot.toDual_map

theorem ofDual_map (f : αᵒᵈ → βᵒᵈ) (a : WithBot αᵒᵈ) :
    WithBot.ofDual (WithBot.map f a) = map (ofDual ∘ f ∘ toDual) (WithBot.ofDual a) :=
  rfl
#align with_bot.of_dual_map WithBot.ofDual_map

section LE

variable [LE α] {a b : α}

theorem toDual_le_iff {a : WithBot α} {b : WithTop αᵒᵈ} :
    WithBot.toDual a ≤ b ↔ WithTop.ofDual b ≤ a :=
  Iff.rfl
#align with_bot.to_dual_le_iff WithBot.toDual_le_iff

theorem le_toDual_iff {a : WithTop αᵒᵈ} {b : WithBot α} :
    a ≤ WithBot.toDual b ↔ b ≤ WithTop.ofDual a :=
  Iff.rfl
#align with_bot.le_to_dual_iff WithBot.le_toDual_iff

@[simp]
theorem toDual_le_toDual_iff {a b : WithBot α} : WithBot.toDual a ≤ WithBot.toDual b ↔ b ≤ a :=
  Iff.rfl
#align with_bot.to_dual_le_to_dual_iff WithBot.toDual_le_toDual_iff

theorem ofDual_le_iff {a : WithBot αᵒᵈ} {b : WithTop α} :
    WithBot.ofDual a ≤ b ↔ WithTop.toDual b ≤ a :=
  Iff.rfl
#align with_bot.of_dual_le_iff WithBot.ofDual_le_iff

theorem le_ofDual_iff {a : WithTop α} {b : WithBot αᵒᵈ} :
    a ≤ WithBot.ofDual b ↔ b ≤ WithTop.toDual a :=
  Iff.rfl
#align with_bot.le_of_dual_iff WithBot.le_ofDual_iff

@[simp]
theorem ofDual_le_ofDual_iff {a b : WithBot αᵒᵈ} : WithBot.ofDual a ≤ WithBot.ofDual b ↔ b ≤ a :=
  Iff.rfl
#align with_bot.of_dual_le_of_dual_iff WithBot.ofDual_le_ofDual_iff

end LE

section LT

variable [LT α] {a b : α}

theorem toDual_lt_iff {a : WithBot α} {b : WithTop αᵒᵈ} :
    WithBot.toDual a < b ↔ WithTop.ofDual b < a :=
  Iff.rfl
#align with_bot.to_dual_lt_iff WithBot.toDual_lt_iff

theorem lt_toDual_iff {a : WithTop αᵒᵈ} {b : WithBot α} :
    a < WithBot.toDual b ↔ b < WithTop.ofDual a :=
  Iff.rfl
#align with_bot.lt_to_dual_iff WithBot.lt_toDual_iff

@[simp]
theorem toDual_lt_toDual_iff {a b : WithBot α} : WithBot.toDual a < WithBot.toDual b ↔ b < a :=
  Iff.rfl
#align with_bot.to_dual_lt_to_dual_iff WithBot.toDual_lt_toDual_iff

theorem ofDual_lt_iff {a : WithBot αᵒᵈ} {b : WithTop α} :
    WithBot.ofDual a < b ↔ WithTop.toDual b < a :=
  Iff.rfl
#align with_bot.of_dual_lt_iff WithBot.ofDual_lt_iff

theorem lt_ofDual_iff {a : WithTop α} {b : WithBot αᵒᵈ} :
    a < WithBot.ofDual b ↔ b < WithTop.toDual a :=
  Iff.rfl
#align with_bot.lt_of_dual_iff WithBot.lt_ofDual_iff

@[simp]
theorem ofDual_lt_ofDual_iff {a b : WithBot αᵒᵈ} : WithBot.ofDual a < WithBot.ofDual b ↔ b < a :=
  Iff.rfl
#align with_bot.of_dual_lt_of_dual_iff WithBot.ofDual_lt_ofDual_iff

end LT

end WithBot

namespace WithTop

section LT

variable [LT α] {a b : α}

open OrderDual

@[simp, norm_cast]
theorem coe_lt_coe : (a : WithTop α) < b ↔ a < b := by
  simp only [← toDual_lt_toDual_iff, toDual_apply_coe, WithBot.coe_lt_coe, toDual_lt_toDual]
#align with_top.coe_lt_coe WithTop.coe_lt_coe

@[simp]
theorem some_lt_some : @LT.lt (WithTop α) _ (Option.some a) (Option.some b) ↔ a < b :=
  coe_lt_coe
#align with_top.some_lt_some WithTop.some_lt_some

theorem coe_lt_top (a : α) : (a : WithTop α) < ⊤ := by
  simp [← toDual_lt_toDual_iff, WithBot.bot_lt_coe]
#align with_top.coe_lt_top WithTop.coe_lt_top

@[simp]
theorem some_lt_none (a : α) : @LT.lt (WithTop α) _ (Option.some a) none :=
  coe_lt_top a
#align with_top.some_lt_none WithTop.some_lt_none

@[simp]
theorem not_none_lt (a : WithTop α) : ¬@LT.lt (WithTop α) _ none a := by
  rw [← toDual_lt_toDual_iff]
  exact WithBot.not_lt_none _
#align with_top.not_none_lt WithTop.not_none_lt

theorem lt_iff_exists_coe {a b : WithTop α} : a < b ↔ ∃ p : α, a = p ∧ ↑p < b := by
  rw [← toDual_lt_toDual_iff, WithBot.lt_iff_exists_coe, OrderDual.exists]
  exact exists_congr fun _ => and_congr_left' Iff.rfl
#align with_top.lt_iff_exists_coe WithTop.lt_iff_exists_coe

theorem coe_lt_iff {x : WithTop α} : ↑a < x ↔ ∀ b, x = ↑b → a < b := by simp
#align with_top.coe_lt_iff WithTop.coe_lt_iff

/-- A version of `lt_top_iff_ne_top` for `WithTop` that only requires `LT α`, not
`PartialOrder α`. -/
protected theorem lt_top_iff_ne_top {x : WithTop α} : x < ⊤ ↔ x ≠ ⊤ :=
  @WithBot.bot_lt_iff_ne_bot αᵒᵈ _ x
#align with_top.lt_top_iff_ne_top WithTop.lt_top_iff_ne_top

end LT

instance preorder [Preorder α] : Preorder (WithTop α) where
  le := (· ≤ ·)
  lt := (· < ·)
  lt_iff_le_not_le := by simp [← toDual_lt_toDual_iff, lt_iff_le_not_le]
  le_refl _ := toDual_le_toDual_iff.mp le_rfl
  le_trans _ _ _ := by
    simp_rw [← toDual_le_toDual_iff]
    exact Function.swap le_trans

instance partialOrder [PartialOrder α] : PartialOrder (WithTop α) :=
  { WithTop.preorder with
    le_antisymm := fun _ _ => by
      simp_rw [← toDual_le_toDual_iff]
      exact Function.swap le_antisymm }
#align with_top.partial_order WithTop.partialOrder

theorem coe_strictMono [Preorder α] : StrictMono (fun a : α => (a : WithTop α)) :=
  fun _ _ => some_lt_some.2
#align with_top.coe_strict_mono WithTop.coe_strictMono

theorem coe_mono [Preorder α] : Monotone (fun a : α => (a : WithTop α)) :=
  fun _ _ => coe_le_coe.2
#align with_top.coe_mono WithTop.coe_mono

theorem monotone_iff [Preorder α] [Preorder β] {f : WithTop α → β} :
    Monotone f ↔ Monotone (fun (a : α) => f a) ∧ ∀ x : α, f x ≤ f ⊤ :=
  ⟨fun h => ⟨h.comp WithTop.coe_mono, fun _ => h le_top⟩, fun h =>
    WithTop.forall.2
      ⟨WithTop.forall.2 ⟨fun _ => le_rfl, fun _ h => (not_top_le_coe _ h).elim⟩, fun x =>
        WithTop.forall.2 ⟨fun _ => h.2 x, fun _ hle => h.1 (coe_le_coe.1 hle)⟩⟩⟩
#align with_top.monotone_iff WithTop.monotone_iff

@[simp]
theorem monotone_map_iff [Preorder α] [Preorder β] {f : α → β} :
    Monotone (WithTop.map f) ↔ Monotone f :=
  monotone_iff.trans <| by simp [Monotone]
#align with_top.monotone_map_iff WithTop.monotone_map_iff

alias monotone_map_iff ↔ _ _root_.Monotone.withTop_map
#align monotone.with_top_map Monotone.withTop_map

theorem strictMono_iff [Preorder α] [Preorder β] {f : WithTop α → β} :
    StrictMono f ↔ StrictMono (fun (a : α) => f a) ∧ ∀ x : α, f x < f ⊤ :=
  ⟨fun h => ⟨h.comp WithTop.coe_strictMono, fun _ => h (coe_lt_top _)⟩, fun h =>
    WithTop.forall.2
      ⟨WithTop.forall.2 ⟨flip absurd (lt_irrefl _), fun _ h => (not_top_lt h).elim⟩, fun x =>
        WithTop.forall.2 ⟨fun _ => h.2 x, fun _ hle => h.1 (coe_lt_coe.1 hle)⟩⟩⟩
#align with_top.strict_mono_iff WithTop.strictMono_iff

theorem strictAnti_iff [Preorder α] [Preorder β] {f : WithTop α → β} :
    StrictAnti f ↔ StrictAnti (λ a => f a : α → β) ∧ ∀ x : α, f ⊤ < f x :=
  strictMono_iff (β := βᵒᵈ)

@[simp]
theorem strictMono_map_iff [Preorder α] [Preorder β] {f : α → β} :
    StrictMono (WithTop.map f) ↔ StrictMono f :=
  strictMono_iff.trans <| by simp [StrictMono, coe_lt_top]
#align with_top.strict_mono_map_iff WithTop.strictMono_map_iff

alias strictMono_map_iff ↔ _ _root_.StrictMono.withTop_map
#align strict_mono.with_top_map StrictMono.withTop_map

theorem map_le_iff [Preorder α] [Preorder β] (f : α → β) (a b : WithTop α)
    (mono_iff : ∀ {a b}, f a ≤ f b ↔ a ≤ b) :
    a.map f ≤ b.map f ↔ a ≤ b := by
  erw [← toDual_le_toDual_iff, toDual_map, toDual_map, WithBot.map_le_iff, toDual_le_toDual_iff]
  simp [mono_iff]
#align with_top.map_le_iff WithTop.map_le_iff

instance semilatticeInf [SemilatticeInf α] : SemilatticeInf (WithTop α) :=
  { WithTop.partialOrder with
    inf := Option.liftOrGet (· ⊓ ·),
    inf_le_left := fun o₁ o₂ a ha => by cases ha ; cases o₂ <;> simp [Option.liftOrGet],
    inf_le_right := fun o₁ o₂ a ha => by cases ha ; cases o₁ <;> simp [Option.liftOrGet],
    le_inf := fun o₁ o₂ o₃ h₁ h₂ a ha => by
      cases' o₂ with b <;> cases' o₃ with c <;> cases ha
      · exact h₂ a rfl

      · exact h₁ a rfl

      · rcases h₁ b rfl with ⟨d, ⟨⟩, h₁'⟩
        simp at h₂
        exact ⟨d, rfl, le_inf h₁' h₂⟩
         }

theorem coe_inf [SemilatticeInf α] (a b : α) : ((a ⊓ b : α) : WithTop α) = (a : WithTop α) ⊓ b :=
  rfl
#align with_top.coe_inf WithTop.coe_inf

instance semilatticeSup [SemilatticeSup α] : SemilatticeSup (WithTop α) :=
  { WithTop.partialOrder with
    sup := Option.map₂ (· ⊔ ·),
    le_sup_left := fun o₁ o₂ a ha => by
      rcases Option.mem_map₂_iff.1 ha with ⟨a, b, (rfl : _ = _), (rfl : _ = _), rfl⟩
      exact ⟨_, rfl, le_sup_left⟩,
    le_sup_right := fun o₁ o₂ a ha => by
      rcases Option.mem_map₂_iff.1 ha with ⟨a, b, (rfl : _ = _), (rfl : _ = _), rfl⟩
      exact ⟨_, rfl, le_sup_right⟩,
    sup_le := fun o₁ o₂ o₃ h₁ h₂ a ha => by
      cases ha
      rcases h₁ a rfl with ⟨b, ⟨⟩, ab⟩
      rcases h₂ a rfl with ⟨c, ⟨⟩, ac⟩
      exact ⟨_, rfl, sup_le ab ac⟩ }

theorem coe_sup [SemilatticeSup α] (a b : α) : ((a ⊔ b : α) : WithTop α) = (a : WithTop α) ⊔ b :=
  rfl
#align with_top.coe_sup WithTop.coe_sup

instance lattice [Lattice α] : Lattice (WithTop α) :=
  { WithTop.semilatticeSup, WithTop.semilatticeInf with }

instance distribLattice [DistribLattice α] : DistribLattice (WithTop α) :=
  { WithTop.lattice with
    le_sup_inf := fun o₁ o₂ o₃ =>
      match o₁, o₂, o₃ with
      | ⊤, _, _ => le_rfl
      | (a₁ : α), ⊤, ⊤ => le_rfl
      | (a₁ : α), ⊤, (a₃ : α) => le_rfl
      | (a₁ : α), (a₂ : α), ⊤ => le_rfl
      | (a₁ : α), (a₂ : α), (a₃ : α) => coe_le_coe.mpr le_sup_inf }

instance decidableLE [LE α] [@DecidableRel α (· ≤ ·)] :
    @DecidableRel (WithTop α) (· ≤ ·) := fun _ _ =>
  decidable_of_decidable_of_iff  toDual_le_toDual_iff
#align with_top.decidable_le WithTop.decidableLE

instance decidableLT [LT α] [@DecidableRel α (· < ·)] :
    @DecidableRel (WithTop α) (· < ·) := fun _ _ =>
  decidable_of_decidable_of_iff toDual_lt_toDual_iff
#align with_top.decidable_lt WithTop.decidableLT

instance isTotal_le [LE α] [IsTotal α (· ≤ ·)] : IsTotal (WithTop α) (· ≤ ·) :=
  ⟨fun _ _ => by
    simp_rw [← toDual_le_toDual_iff]
    exact total_of _ _ _⟩
#align with_top.is_total_le WithTop.isTotal_le

instance linearOrder [LinearOrder α] : LinearOrder (WithTop α) :=
  Lattice.toLinearOrder _
#align with_top.linear_order WithTop.linearOrder

@[simp, norm_cast]
theorem coe_min [LinearOrder α] (x y : α) : (↑(min x y) : WithTop α) = min (x : WithTop α) y :=
  rfl
#align with_top.coe_min WithTop.coe_min

@[simp, norm_cast]
theorem coe_max [LinearOrder α] (x y : α) : (↑(max x y) : WithTop α) = max (x : WithTop α) y :=
  rfl
#align with_top.coe_max WithTop.coe_max

theorem wellFounded_lt [Preorder α] (h : @WellFounded α (· < ·)) :
    @WellFounded (WithTop α) (· < ·) :=
  have acc_some : ∀ a : α, Acc ((· < ·) : WithTop α → WithTop α → Prop) (some a) := fun a =>
    Acc.intro _
      (WellFounded.induction h a
        (show
          ∀ b, (∀ c, c < b → ∀ d : WithTop α, d < some c → Acc (· < ·) d) →
            ∀ y : WithTop α, y < some b → Acc (· < ·) y
          from fun _ ih c =>
          Option.recOn c (fun hc => (not_lt_of_ge le_top hc).elim) fun _ hc =>
            Acc.intro _ (ih _ (some_lt_some.1 hc))))
  ⟨fun a =>
    Option.recOn a (Acc.intro _ fun y => Option.recOn y
      (fun h => (lt_irrefl _ h).elim) fun _ _ => acc_some _) acc_some⟩
#align with_top.well_founded_lt WithTop.wellFounded_lt

open OrderDual

theorem wellFounded_gt [Preorder α] (h : @WellFounded α (· > ·)) :
    @WellFounded (WithTop α) (· > ·) :=
  ⟨fun a => by
    -- ideally, use rel_hom_class.acc, but that is defined later
    have : Acc (· < ·) (WithTop.toDual a) := WellFounded.apply (WithBot.wellFounded_lt
      (by convert h using 1)) _
    revert this
    generalize ha : WithBot.toDual a = b
    intro ac
    dsimp at ac
    induction' ac with _ H IH generalizing a
    subst ha
    exact ⟨_, fun a' h => IH (WithTop.toDual a') (toDual_lt_toDual.mpr h) _ rfl⟩⟩
#align with_top.well_founded_gt WithTop.wellFounded_gt

theorem _root_.WithBot.wellFounded_gt [Preorder α] (h : @WellFounded α (· > ·)) :
    @WellFounded (WithBot α) (· > ·) :=
  ⟨fun a => by
    -- ideally, use rel_hom_class.acc, but that is defined later
    have : Acc (· < ·) (WithBot.toDual a) :=
      WellFounded.apply (WithTop.wellFounded_lt (by convert h using 1)) _
    revert this
    generalize ha : WithBot.toDual a = b
    intro ac
    dsimp at ac
    induction' ac with _ H IH generalizing a
    subst ha
    exact ⟨_, fun a' h => IH (WithBot.toDual a') (toDual_lt_toDual.mpr h) _ rfl⟩⟩
#align with_bot.well_founded_gt WithBot.wellFounded_gt

instance trichotomous.lt [Preorder α] [IsTrichotomous α (· < ·)] :
    IsTrichotomous (WithTop α) (· < ·) :=
  ⟨by
    rintro (a | a) (b | b)
    . simp
    . simp
    . simp
    . simpa [some_eq_coe, IsTrichotomous, coe_eq_coe] using @trichotomous α (. < .) _ a b⟩
#align with_top.trichotomous.lt WithTop.trichotomous.lt

instance IsWellOrder.lt [Preorder α] [h : IsWellOrder α (· < ·)] :
    IsWellOrder (WithTop α) (· < ·) where wf := wellFounded_lt h.wf
#align with_top.is_well_order.lt WithTop.IsWellOrder.lt

instance trichotomous.gt [Preorder α] [IsTrichotomous α (· > ·)] :
    IsTrichotomous (WithTop α) (· > ·) :=
  ⟨by
    rintro (a | a) (b | b)
    . simp
    . simp
    . simp
    . simpa [some_eq_coe, IsTrichotomous, coe_eq_coe] using @trichotomous α (. > .) _ a b⟩
#align with_top.trichotomous.gt WithTop.trichotomous.gt

instance IsWellOrder.gt [Preorder α] [h : IsWellOrder α (· > ·)] :
    IsWellOrder (WithTop α) (· > ·) where wf := wellFounded_gt h.wf
#align with_top.is_well_order.gt WithTop.IsWellOrder.gt

instance _root_.WithBot.trichotomous.lt [Preorder α] [h : IsTrichotomous α (· < ·)] :
    IsTrichotomous (WithBot α) (· < ·) :=
  @WithTop.trichotomous.gt αᵒᵈ _ h
#align with_bot.trichotomous.lt WithBot.trichotomous.lt

instance _root_.WithBot.isWellOrder.lt [Preorder α] [h : IsWellOrder α (· < ·)] :
    IsWellOrder (WithBot α) (· < ·) :=
  @WithTop.IsWellOrder.gt αᵒᵈ _ h
#align with_bot.is_well_order.lt WithBot.isWellOrder.lt

instance _root_.WithBot.trichotomous.gt [Preorder α] [h : IsTrichotomous α (· > ·)] :
    IsTrichotomous (WithBot α) (· > ·) :=
  @WithTop.trichotomous.lt αᵒᵈ _ h
#align with_bot.trichotomous.gt WithBot.trichotomous.gt

instance _root_.WithBot.isWellOrder.gt [Preorder α] [h : IsWellOrder α (· > ·)] :
    IsWellOrder (WithBot α) (· > ·) :=
  @WithTop.IsWellOrder.lt αᵒᵈ _ h
#align with_bot.is_well_order.gt WithBot.isWellOrder.gt

instance [LT α] [DenselyOrdered α] [NoMaxOrder α] : DenselyOrdered (WithTop α) :=
  OrderDual.denselyOrdered (WithBot αᵒᵈ)

theorem lt_iff_exists_coe_btwn [Preorder α] [DenselyOrdered α] [NoMaxOrder α] {a b : WithTop α} :
    a < b ↔ ∃ x : α, a < ↑x ∧ ↑x < b :=
  ⟨fun h =>
    let ⟨_, hy⟩ := exists_between h
    let ⟨x, hx⟩ := lt_iff_exists_coe.1 hy.2
    ⟨x, hx.1 ▸ hy⟩,
    fun ⟨_, hx⟩ => lt_trans hx.1 hx.2⟩
#align with_top.lt_iff_exists_coe_btwn WithTop.lt_iff_exists_coe_btwn

instance noBotOrder [LE α] [NoBotOrder α] [Nonempty α] : NoBotOrder (WithTop α) :=
  @OrderDual.noBotOrder (WithBot αᵒᵈ) _ _

instance noMinOrder [LT α] [NoMinOrder α] [Nonempty α] : NoMinOrder (WithTop α) :=
  @OrderDual.noMinOrder (WithBot αᵒᵈ) _ _

end WithTop


import Days
import Days.Common
import Std
import Lean.Data.Parsec

open Days
open Days.Common
namespace Days.Day09
def day: ProblemNumber := 09

open Std (RBSet mkRBSet)
open Lean.Parsec
open Lean (Parsec)

def sample := "R 4
U 4
L 3
D 1
R 4
D 1
L 5
R 2"

structure Point where
  x: Int
  y: Int
  deriving Ord, BEq, DecidableEq, Hashable, Inhabited

abbrev PointSet: Type := RBSet Point compare

instance : ToString Point where
  toString point := s!"({point.x},{point.y})"

instance : Repr Point where
  reprPrec point _ :=
    .text (toString point)

structure Rope where
  head: Point
  tail: Array Point

instance : Inhabited Rope where
  default := { head := default, tail := #[default]}

instance : Repr Rope where
  reprPrec rope _ :=
    .text s!"h{rope.head}{rope.tail}"

def toArray (range: Std.Range) : Array Nat := Id.run <| do
  let mut result := #[]

  for i in range do
    result := result.push i

  return result

def Rope.visualString (rope: Rope) : String := Id.run <| do
  let points := rope.head::rope.tail.toList
  let maxX: Int := points|>.map (·.x) |>.maximum? |>.get!
  let minX: Int := points|>.map (·.x) |>.minimum? |>.get!
  let maxY: Int := points|>.map (·.y) |>.maximum? |>.get!
  let minY: Int := points|>.map (·.y) |>.minimum? |>.get!
  if minY < 0 ∨ minX < 0 then panic! "Need to adjust min i guess"

  let gridSizeX := maxX + 1 |>.natAbs
  let gridSizeY := maxY + 1 |>.natAbs

  let squareGrid := Max.max gridSizeX gridSizeY

  let mut grid: Array $ Array String := Array.mkArray squareGrid (Array.mkArray squareGrid "·")

  for (idx, point) in points.enum do
    let yRow: Array String := grid.get! point.y.natAbs
    let char: String :=
      if idx = 0 then "H" else
      if idx < 10 then toString idx
      else "X"
    let result := yRow.set! point.x.natAbs char
    let newGrid := grid.set! point.y.natAbs result
    grid := newGrid

  let p: Array String :=
    grid.reverse
    |>.map Array.toList
    |>.map (String.intercalate "")

  return p
  |>.toList
  |> (String.intercalate "\n")
  |>.push '\n'
  |>.append (Array.mkArray squareGrid "-" |>.toList |> String.intercalate "")
  |>.push '\n'
  |>.append ([:Min.min squareGrid 10] |> toArray |>.map toString |>.toList |> String.intercalate ""
  |>.append s!"\n {squareGrid}×{squareGrid}")

def Rope.print (rope: Rope) : IO Unit := do
  IO.println rope.visualString
  IO.println ""

inductive Direction where
  | right : Direction
  | up : Direction
  | down : Direction
  | left : Direction
  deriving Repr, Inhabited

inductive RopeMovement where
  | move : Direction -> Nat -> RopeMovement
  deriving Repr, Inhabited

def RopeMovement.parse : Parsec RopeMovement := do
  match ← (pchar 'R' <|> pchar 'L' <|> pchar 'U' <|> pchar 'D') <* ws, ← many1Chars digit with
  | 'R', cnt => return .move .right cnt.toNat!
  | 'D', cnt => return .move .down cnt.toNat!
  | 'U', cnt => return .move .up cnt.toNat!
  | 'L', cnt => return .move .left cnt.toNat!
  | m, _ => fail s!"Failed to parse rope movement from char '{m}'"

def RopeMovement.parseMovements [ToInput α] (i: α) : Except String (Array RopeMovement) :=
  toInput i
  |>.lines
  |>.map (·.trim.text.iter)
  |>.map RopeMovement.parse
  |>.foldl (init:=.ok #[]) λ
  | .error msg, _ | _, .error _ msg => .error msg
  | .ok state, .success _ mvmt => .ok <| state.push mvmt

#eval RopeMovement.parseMovements sample

def pointΔ (leader: Point) (follower: Point) : Point :=
  match follower, leader with
  | { x:=tx, y:=ty }, { x:=hx, y:=hy } =>
    let Δx := hx-tx
    let Δy := hy-ty
    { x:= Δx, y:=Δy }

instance : Sub Point where
  sub := pointΔ

def Point.asUnitVec (point: Point) : Point :=
  let {x, y} := point
  { x:= if x = 0 then 0 else x/x.natAbs,
    y:= if y = 0 then 0 else y/y.natAbs }

instance : Add Point where
  add p₁ p₂ := { x := p₁.x + p₂.x, y := p₁.y + p₂.y }

def adjustKnot (leader: Point) (follower: Point) : Point :=
  let delta@{ x:= Δx, y:=Δy } := leader - follower
  if Δx.natAbs ≥ 2 ∨ Δy.natAbs ≥ 2
  then follower + delta.asUnitVec
  else follower

def adjustTailKnots (rope: Rope): Rope :=
  { rope with tail := foldAdjustKnots rope.head rope.tail }
  where
    foldAdjustKnots (head: Point) (knots: Array Point): Array Point :=
      knots.foldl (init:=(head, #[])) (λ
      | (leader, tail), knot =>
        let newPos := adjustKnot leader knot
        (newPos, tail.push newPos))
      |>.snd

/--
Sample
```
...H.. (3,4)
....T. (4,3)
......
......
s.....
```
```
..HT.. (2,4)(3,4)
......
......
......
s.....
```
-/
theorem adjust_test1 : adjustKnot (.mk 2 4) (.mk 4 3) = (.mk 3 4) := by rfl

#eval Rope.mk (.mk 3 4) #[.mk 4 3] |> Rope.print

#eval adjustKnot (.mk 2 4) (.mk 4 3)

#eval adjustTailKnots { head := .mk 2 4, tail := #[.mk 4 3] }

#eval Rope.print <| adjustTailKnots { head := .mk 2 4, tail := #[.mk 4 3] }

/--
```
..T...(2,4)
...H..(3,3)
......
......
s.....
```
```
......
...TH.(3,3)(4,3)
......
......
s.....
```
```
......
....TH(4,3),(5,3)
......
......
s.....
```
-/
theorem adjust_test2 :
  adjustTailKnots { head := .mk 5 3, tail := #[.mk 3 4] }
  = { head := .mk 5 3, tail := #[.mk 4 3] }
  := by rfl

#eval adjustTailKnots { head := .mk 3 3, tail := #[.mk 2 4] }
#eval adjustTailKnots { head := .mk 5 3, tail := #[.mk 3 4] }

def Rope.move (rope: Rope) (mvmts: Array RopeMovement) : Array Rope :=
  rope
  |> applyMovements
  where
    mvHead (dir: Direction) (rope: Rope): Rope :=
      match dir with
      | .up => { rope with head := { rope.head with y := rope.head.y + 1}}
      | .down => { rope with head := { rope.head with y := rope.head.y - 1}}
      | .left => { rope with head := { rope.head with x := rope.head.x - 1}}
      | .right => { rope with head := { rope.head with x := rope.head.x + 1}}

    apply (rope: Rope) (result: Array Rope) (mvmt: RopeMovement) : Rope × Array Rope :=
    match mvmt with
    | .move _ 0 => (rope, result)
    | .move dir (cnt + 1) =>
      let newRopeHead := mvHead dir rope
      let newRope := adjustTailKnots newRopeHead
      apply newRope (result.push newRope) (.move dir cnt)

    applyMovements (rope: Rope) : Array Rope :=
      mvmts.foldl (init:=(rope, #[rope])) (λ
        | (rope, list), mvmt => apply rope list mvmt) |>.snd

def printRopes (ropes: Array Rope) : IO Unit := do
  for rope in ropes do
    rope.print
  return ()

#eval Rope.move (default) <| (RopeMovement.parseMovements sample).toOption.get!

#eval printRopes <| Rope.move (default) <| (RopeMovement.parseMovements sample).toOption.get!

def Rope.tailPath (rope: Rope) (mvmts: Array RopeMovement) : Array Point :=
  rope.move mvmts
  |>.map (·.tail)
  |>.map (λ knots => knots.reverse.toList.head!)

/-
..##..
...##.
.####.
....#.
s###..
-/
#eval Rope.tailPath (default) <| (RopeMovement.parseMovements sample).toOption.get!

def Rope.distinctTailPath (rope: Rope) (mvmts: Array RopeMovement) : PointSet :=
  rope.tailPath mvmts
  |> RBSet.ofArray (cmp:=compare)

#eval Rope.distinctTailPath (default) <| (RopeMovement.parseMovements sample).toOption.get!

def part₁ (input: Input) : Nat :=
  mvmts
  |> Rope.distinctTailPath (rope:=default)
  |>.size
  where
    mvmts: Array RopeMovement :=
      match RopeMovement.parseMovements input with
      | .ok res => res
      | .error error => panic! s!"Error: {error}"

/--
-/
def part₂ (input: Input) : Nat :=
  mvmts
  |> Rope.distinctTailPath (rope:=.mk default (Array.mkArray 9 default))
  |>.size
  where
    mvmts: Array RopeMovement :=
      match RopeMovement.parseMovements input with
      | .ok res => res
      | .error error => panic! s!"Error: {error}"

def solution : Problem Nat := ⟨ day, part₁, part₂ ⟩

#eval testPart₁ solution sample (expect:=13)

-- #eval printRopes <| Rope.move (rope:=.mk default (Array.mkArray 9 default)) <| (RopeMovement.parseMovements sample).toOption.get!
#eval testPart₂ solution sample (expect:=1)

def sample₂ := "R 5
U 8
L 8
D 3
R 17
D 10
L 25
U 20"

#eval printRopes <| Rope.move (rope:=.mk default (Array.mkArray 9 default)) <| (RopeMovement.parseMovements sample₂).toOption.get!
#eval testPart₂ solution sample₂ (expect:=36)


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.fp.basic
! leanprover-community/mathlib commit 4c19a16e4b705bf135cf9a80ac18fcc99c438514
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Semiquot
import Mathbin.Data.Rat.Floor

/-!
# Implementation of floating-point numbers (experimental).

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

#print Int.shift2 /-
def Int.shift2 (a b : ℕ) : ℤ → ℕ × ℕ
  | Int.ofNat e => (a.shiftl e, b)
  | -[e+1] => (a, b.shiftl e.succ)
#align int.shift2 Int.shift2
-/

namespace Fp

#print FP.RMode /-
inductive RMode
  | NE
  deriving Inhabited
#align fp.rmode FP.RMode
-/

#print FP.FloatCfg /-
-- round to nearest even
class FloatCfg where
  (prec emax : ℕ)
  prec_pos : 0 < prec
  prec_max : prec ≤ emax
#align fp.float_cfg FP.FloatCfg
-/

variable [C : FloatCfg]

include C

#print FP.prec /-
def prec :=
  C.prec
#align fp.prec FP.prec
-/

#print FP.emax /-
def emax :=
  C.emax
#align fp.emax FP.emax
-/

#print FP.emin /-
def emin : ℤ :=
  1 - C.emax
#align fp.emin FP.emin
-/

#print FP.ValidFinite /-
def ValidFinite (e : ℤ) (m : ℕ) : Prop :=
  emin ≤ e + prec - 1 ∧ e + prec - 1 ≤ emax ∧ e = max (e + m.size - prec) emin
#align fp.valid_finite FP.ValidFinite
-/

#print FP.decValidFinite /-
instance decValidFinite (e m) : Decidable (ValidFinite e m) := by
  unfold valid_finite <;> infer_instance
#align fp.dec_valid_finite FP.decValidFinite
-/

#print FP.Float /-
inductive Float
  | inf : Bool → float
  | nan : float
  | Finite : Bool → ∀ e m, ValidFinite e m → float
#align fp.float FP.Float
-/

#print FP.Float.isFinite /-
def Float.isFinite : Float → Bool
  | float.finite s e m f => true
  | _ => false
#align fp.float.is_finite FP.Float.isFinite
-/

#print FP.toRat /-
def toRat : ∀ f : Float, f.isFinite → ℚ
  | float.finite s e m f, _ =>
    let (n, d) := Int.shift2 m 1 e
    let r := mkRat n d
    if s then -r else r
#align fp.to_rat FP.toRat
-/

#print FP.Float.Zero.valid /-
theorem Float.Zero.valid : ValidFinite emin 0 :=
  ⟨by
    rw [add_sub_assoc]
    apply le_add_of_nonneg_right
    apply sub_nonneg_of_le
    apply Int.ofNat_le_ofNat_of_le
    exact C.prec_pos,
    suffices prec ≤ 2 * emax by
      rw [← Int.ofNat_le] at this
      rw [← sub_nonneg] at *
      simp only [emin, emax] at *
      ring_nf
      assumption
    le_trans C.prec_max (Nat.le_mul_of_pos_left (by decide)),
    by rw [max_eq_right] <;> simp [sub_eq_add_neg]⟩
#align fp.float.zero.valid FP.Float.Zero.valid
-/

#print FP.Float.zero /-
def Float.zero (s : Bool) : Float :=
  Float.finite s emin 0 Float.Zero.valid
#align fp.float.zero FP.Float.zero
-/

instance : Inhabited Float :=
  ⟨Float.zero true⟩

/- warning: fp.float.sign' -> FP.Float.sign' is a dubious translation:
lean 3 declaration is
  forall [C : FP.FloatCfg], (FP.Float C) -> (Semiquotₓ.{u_1, 0} Bool)
but is expected to have type
  forall [C : FP.FloatCfg], (FP.Float C) -> (Semiquot.{0} Bool)
Case conversion may be inaccurate. Consider using '#align fp.float.sign' FP.Float.sign'ₓ'. -/
protected def Float.sign' : Float → Semiquot Bool
  | float.inf s => pure s
  | float.nan => ⊤
  | float.finite s e m f => pure s
#align fp.float.sign' FP.Float.sign'

#print FP.Float.sign /-
protected def Float.sign : Float → Bool
  | float.inf s => s
  | float.nan => false
  | float.finite s e m f => s
#align fp.float.sign FP.Float.sign
-/

#print FP.Float.isZero /-
protected def Float.isZero : Float → Bool
  | float.finite s e 0 f => true
  | _ => false
#align fp.float.is_zero FP.Float.isZero
-/

#print FP.Float.neg /-
protected def Float.neg : Float → Float
  | float.inf s => Float.inf (not s)
  | float.nan => Float.nan
  | float.finite s e m f => Float.finite (not s) e m f
#align fp.float.neg FP.Float.neg
-/

/- warning: fp.div_nat_lt_two_pow -> FP.divNatLtTwoPowₓ is a dubious translation:
lean 3 declaration is
  forall [C : FP.FloatCfg], Nat -> Nat -> Int -> Bool
but is expected to have type
  Nat -> Nat -> Int -> Bool
Case conversion may be inaccurate. Consider using '#align fp.div_nat_lt_two_pow FP.divNatLtTwoPowₓₓ'. -/
def divNatLtTwoPow (n d : ℕ) : ℤ → Bool
  | Int.ofNat e => n < d.shiftl e
  | -[e+1] => n.shiftl e.succ < d
#align fp.div_nat_lt_two_pow FP.divNatLtTwoPowₓ

#print FP.ofPosRatDn /-
-- TODO(Mario): Prove these and drop 'meta'
unsafe def ofPosRatDn (n : ℕ+) (d : ℕ+) : Float × Bool :=
  by
  let e₁ : ℤ := n.1.size - d.1.size - prec
  cases' h₁ : Int.shift2 d.1 n.1 (e₁ + prec) with d₁ n₁
  let e₂ := if n₁ < d₁ then e₁ - 1 else e₁
  let e₃ := max e₂ emin
  cases' h₂ : Int.shift2 d.1 n.1 (e₃ + prec) with d₂ n₂
  let r := mkRat n₂ d₂
  let m := r.floor
  refine' (float.finite ff e₃ (Int.toNat m) _, r.denom = 1)
  · exact undefined
#align fp.of_pos_rat_dn FP.ofPosRatDn
-/

#print FP.nextUpPos /-
unsafe def nextUpPos (e m) (v : ValidFinite e m) : Float :=
  let m' := m.succ
  if ss : m'.size = m.size then
    Float.finite false e m' (by unfold valid_finite at * <;> rw [ss] <;> exact v)
  else if h : e = emax then Float.inf false else Float.finite false e.succ (Nat.div2 m') undefined
#align fp.next_up_pos FP.nextUpPos
-/

#print FP.nextDnPos /-
unsafe def nextDnPos (e m) (v : ValidFinite e m) : Float :=
  match m with
  | 0 => nextUpPos _ _ Float.Zero.valid
  | Nat.succ m' =>
    if ss : m'.size = m.size then
      Float.finite false e m' (by unfold valid_finite at * <;> rw [ss] <;> exact v)
    else
      if h : e = emin then Float.finite false emin m' undefined
      else Float.finite false e.pred (bit1 m') undefined
#align fp.next_dn_pos FP.nextDnPos
-/

#print FP.nextUp /-
unsafe def nextUp : Float → Float
  | float.finite ff e m f => nextUpPos e m f
  | float.finite tt e m f => Float.neg <| nextDnPos e m f
  | f => f
#align fp.next_up FP.nextUp
-/

#print FP.nextDn /-
unsafe def nextDn : Float → Float
  | float.finite ff e m f => nextDnPos e m f
  | float.finite tt e m f => Float.neg <| nextUpPos e m f
  | f => f
#align fp.next_dn FP.nextDn
-/

#print FP.ofRatUp /-
unsafe def ofRatUp : ℚ → Float
  | ⟨0, _, _, _⟩ => Float.zero false
  | ⟨Nat.succ n, d, h, _⟩ =>
    let (f, exact) := ofPosRatDn n.succPNat ⟨d, h⟩
    if exact then f else nextUp f
  | ⟨-[n+1], d, h, _⟩ => Float.neg (ofPosRatDn n.succPNat ⟨d, h⟩).1
#align fp.of_rat_up FP.ofRatUp
-/

#print FP.ofRatDn /-
unsafe def ofRatDn (r : ℚ) : Float :=
  Float.neg <| ofRatUp (-r)
#align fp.of_rat_dn FP.ofRatDn
-/

#print FP.ofRat /-
unsafe def ofRat : RMode → ℚ → Float
  | rmode.NE, r =>
    let low := ofRatDn r
    let high := ofRatUp r
    if hf : high.isFinite then
      if r = toRat _ hf then high
      else
        if lf : low.isFinite then
          if r - toRat _ lf > toRat _ hf - r then high
          else
            if r - toRat _ lf < toRat _ hf - r then low
            else
              match low, lf with
              | float.finite s e m f, _ => if 2 ∣ m then low else high
        else Float.inf true
    else Float.inf false
#align fp.of_rat FP.ofRat
-/

namespace Float

instance : Neg Float :=
  ⟨Float.neg⟩

#print FP.Float.add /-
unsafe def add (mode : RMode) : Float → Float → Float
  | nan, _ => nan
  | _, nan => nan
  | inf tt, inf ff => nan
  | inf ff, inf tt => nan
  | inf s₁, _ => inf s₁
  | _, inf s₂ => inf s₂
  | Finite s₁ e₁ m₁ v₁, Finite s₂ e₂ m₂ v₂ =>
    let f₁ := finite s₁ e₁ m₁ v₁
    let f₂ := finite s₂ e₂ m₂ v₂
    ofRat mode (toRat f₁ rfl + toRat f₂ rfl)
#align fp.float.add FP.Float.add
-/

unsafe instance : Add Float :=
  ⟨Float.add RMode.NE⟩

#print FP.Float.sub /-
unsafe def sub (mode : RMode) (f1 f2 : Float) : Float :=
  add mode f1 (-f2)
#align fp.float.sub FP.Float.sub
-/

unsafe instance : Sub Float :=
  ⟨Float.sub RMode.NE⟩

#print FP.Float.mul /-
unsafe def mul (mode : RMode) : Float → Float → Float
  | nan, _ => nan
  | _, nan => nan
  | inf s₁, f₂ => if f₂.isZero then nan else inf (xor s₁ f₂.sign)
  | f₁, inf s₂ => if f₁.isZero then nan else inf (xor f₁.sign s₂)
  | Finite s₁ e₁ m₁ v₁, Finite s₂ e₂ m₂ v₂ =>
    let f₁ := finite s₁ e₁ m₁ v₁
    let f₂ := finite s₂ e₂ m₂ v₂
    ofRat mode (toRat f₁ rfl * toRat f₂ rfl)
#align fp.float.mul FP.Float.mul
-/

#print FP.Float.div /-
unsafe def div (mode : RMode) : Float → Float → Float
  | nan, _ => nan
  | _, nan => nan
  | inf s₁, inf s₂ => nan
  | inf s₁, f₂ => inf (xor s₁ f₂.sign)
  | f₁, inf s₂ => zero (xor f₁.sign s₂)
  | Finite s₁ e₁ m₁ v₁, Finite s₂ e₂ m₂ v₂ =>
    let f₁ := finite s₁ e₁ m₁ v₁
    let f₂ := finite s₂ e₂ m₂ v₂
    if f₂.isZero then inf (xor s₁ s₂) else ofRat mode (toRat f₁ rfl / toRat f₂ rfl)
#align fp.float.div FP.Float.div
-/

end Float

end Fp


import GMLInit.Data.Index.Basic
import GMLInit.Data.Index.Append
import GMLInit.Data.Index.Map

namespace List

def indexIotaTR {α} (xs : List α) : List (Index xs) :=
  let rec loop : (xs : List α) → (ys : List α) → Array (Index (ys.reverse ++ xs)) → List (Index (ys.reverse ++ xs))
  | [], ys, rs => List.append_nil ys.reverse ▸ rs.data
  | x :: xs, ys, rs =>
    have : ys.reverse ++ (x :: xs) = (x :: ys).reverse ++ xs := by
      rw [reverse_cons, append_assoc, singleton_append]
    this ▸ loop xs (x :: ys) (this ▸ rs.push (Index.append_inr Index.head))
  loop xs [] #[]

@[implemented_by indexIotaTR] -- TODO: use csimp
def indexIota {α} : (xs : List α) → List (Index xs)
| [] => []
| _::xs => Index.head :: (indexIota xs).map Index.tail

end List

namespace Index
variable {α} {xs : List α}

def iota : {xs : List α} → Index xs → Index xs.indexIota
| _::_, Index.head => Index.head
| _::_, Index.tail i => Index.tail ((iota i).map Index.tail)

theorem val_iota (i : Index xs) : val (iota i) = i := by
  induction i with
  | head => rfl
  | tail i ih => rw [iota, val_tail, val_map, ih]

theorem iota_val (i : Index xs.indexIota) : iota (val i) = i := by
  induction xs with
  | nil => contradiction
  | cons x xs ih =>
    match i with
    | head => rfl
    | tail i => rw [←map_unmap Index.tail i, val_tail, val_unmap Index.tail, iota, ih, map_unmap]

def iotaEquiv (xs : List α) : Equiv (Index xs) (Index xs.indexIota) where
  fwd := iota
  rev := val
  spec := by
    intros
    constr
    · intro | rfl => exact val_iota ..
    · intro | rfl => exact iota_val ..

end Index