/-
Copyright (c) 2018 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.enat
import Mathlib.data.set.intervals.ord_connected
import Mathlib.PostPort

universes u_1 u_4 l u_3 u_2

namespace Mathlib

/-!
# Theory of conditionally complete lattices.

A conditionally complete lattice is a lattice in which every non-empty bounded subset s
has a least upper bound and a greatest lower bound, denoted below by Sup s and Inf s.
Typical examples are real, nat, int with their usual orders.

The theory is very comparable to the theory of complete lattices, except that suitable
boundedness and nonemptiness assumptions have to be added to most statements.
We introduce two predicates bdd_above and bdd_below to express this boundedness, prove
their basic properties, and then go on to prove most useful properties of Sup and Inf
in conditionally complete lattices.

To differentiate the statements between complete lattices and conditionally complete
lattices, we prefix Inf and Sup in the statements by c, giving cInf and cSup. For instance,
Inf_le is a statement in complete lattices ensuring Inf s ≤ x, while cInf_le is the same
statement in conditionally complete lattices with an additional assumption that s is
bounded below.
-/

/-!
Extension of Sup and Inf from a preorder `α` to `with_top α` and `with_bot α`
-/

protected instance with_top.has_Sup {α : Type u_1} [preorder α] [has_Sup α] :
    has_Sup (with_top α) :=
  has_Sup.mk
    fun (S : set (with_top α)) => ite (⊤ ∈ S) ⊤ (ite (bdd_above (coe ⁻¹' S)) ↑(Sup (coe ⁻¹' S)) ⊤)

protected instance with_top.has_Inf {α : Type u_1} [has_Inf α] : has_Inf (with_top α) :=
  has_Inf.mk fun (S : set (with_top α)) => ite (S ⊆ singleton ⊤) ⊤ ↑(Inf (coe ⁻¹' S))

protected instance with_bot.has_Sup {α : Type u_1} [has_Sup α] : has_Sup (with_bot α) :=
  has_Sup.mk Inf

protected instance with_bot.has_Inf {α : Type u_1} [preorder α] [has_Inf α] :
    has_Inf (with_bot α) :=
  has_Inf.mk Sup

/-- A conditionally complete lattice is a lattice in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete lattices, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_lattice (α : Type u_4) extends lattice α, has_Sup α, has_Inf α where
  le_cSup : ∀ (s : set α) (a : α), bdd_above s → a ∈ s → a ≤ Sup s
  cSup_le : ∀ (s : set α) (a : α), set.nonempty s → a ∈ upper_bounds s → Sup s ≤ a
  cInf_le : ∀ (s : set α) (a : α), bdd_below s → a ∈ s → Inf s ≤ a
  le_cInf : ∀ (s : set α) (a : α), set.nonempty s → a ∈ lower_bounds s → a ≤ Inf s

/-- A conditionally complete linear order is a linear order in which
every nonempty subset which is bounded above has a supremum, and
every nonempty subset which is bounded below has an infimum.
Typical examples are real numbers or natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order (α : Type u_4)
    extends linear_order α, conditionally_complete_lattice α where

/-- A conditionally complete linear order with `bot` is a linear order with least element, in which
every nonempty subset which is bounded above has a supremum, and every nonempty subset (necessarily
bounded below) has an infimum.  A typical example is the natural numbers.

To differentiate the statements from the corresponding statements in (unconditional)
complete linear orders, we prefix Inf and Sup by a c everywhere. The same statements should
hold in both worlds, sometimes with additional assumptions of nonemptiness or
boundedness.-/
class conditionally_complete_linear_order_bot (α : Type u_4)
    extends order_bot α, conditionally_complete_linear_order α where
  cSup_empty : Sup ∅ = ⊥

/- A complete lattice is a conditionally complete lattice, as there are no restrictions
on the properties of Inf and Sup in a complete lattice.-/

protected instance conditionally_complete_lattice_of_complete_lattice {α : Type u_1}
    [complete_lattice α] : conditionally_complete_lattice α :=
  conditionally_complete_lattice.mk complete_lattice.sup complete_lattice.le complete_lattice.lt
    complete_lattice.le_refl complete_lattice.le_trans complete_lattice.le_antisymm
    complete_lattice.le_sup_left complete_lattice.le_sup_right complete_lattice.sup_le
    complete_lattice.inf complete_lattice.inf_le_left complete_lattice.inf_le_right
    complete_lattice.le_inf complete_lattice.Sup complete_lattice.Inf sorry sorry sorry sorry

protected instance conditionally_complete_linear_order_of_complete_linear_order {α : Type u_1}
    [complete_linear_order α] : conditionally_complete_linear_order α :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup
    conditionally_complete_lattice.le conditionally_complete_lattice.lt sorry sorry sorry sorry
    sorry sorry conditionally_complete_lattice.inf sorry sorry sorry
    conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry
    complete_linear_order.le_total complete_linear_order.decidable_le
    complete_linear_order.decidable_eq complete_linear_order.decidable_lt

theorem le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : bdd_above s) (h₂ : a ∈ s) : a ≤ Sup s :=
  conditionally_complete_lattice.le_cSup s a h₁ h₂

theorem cSup_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → b ≤ a) : Sup s ≤ a :=
  conditionally_complete_lattice.cSup_le s a h₁ h₂

theorem cInf_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : bdd_below s) (h₂ : a ∈ s) : Inf s ≤ a :=
  conditionally_complete_lattice.cInf_le s a h₁ h₂

theorem le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (h₁ : set.nonempty s) (h₂ : ∀ (b : α), b ∈ s → a ≤ b) : a ≤ Inf s :=
  conditionally_complete_lattice.le_cInf s a h₁ h₂

theorem le_cSup_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_above s) (hb : b ∈ s) (h : a ≤ b) : a ≤ Sup s :=
  le_trans h (le_cSup _x hb)

theorem cInf_le_of_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_below s) (hb : b ∈ s) (h : b ≤ a) : Inf s ≤ a :=
  le_trans (cInf_le _x hb) h

theorem cSup_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_above t) : set.nonempty s → s ⊆ t → Sup s ≤ Sup t :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) =>
    cSup_le _x_1 fun (a : α) (ha : a ∈ s) => le_cSup _x (h ha)

theorem cInf_le_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_below t) : set.nonempty s → s ⊆ t → Inf t ≤ Inf s :=
  fun (_x_1 : set.nonempty s) (h : s ⊆ t) =>
    le_cInf _x_1 fun (a : α) (ha : a ∈ s) => cInf_le _x (h ha)

theorem is_lub_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (ne : set.nonempty s) (H : bdd_above s) : is_lub s (Sup s) :=
  { left := fun (x : α) => le_cSup H, right := fun (x : α) => cSup_le ne }

theorem is_glb_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (ne : set.nonempty s) (H : bdd_below s) : is_glb s (Inf s) :=
  { left := fun (x : α) => cInf_le H, right := fun (x : α) => le_cInf ne }

theorem is_lub.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_lub s a) (ne : set.nonempty s) : Sup s = a :=
  is_lub.unique (is_lub_cSup ne (Exists.intro a (and.left H))) H

/-- A greatest element of a set is the supremum of this set. -/
theorem is_greatest.cSup_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_greatest s a) : Sup s = a :=
  is_lub.cSup_eq (is_greatest.is_lub H) (is_greatest.nonempty H)

theorem is_glb.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_glb s a) (ne : set.nonempty s) : Inf s = a :=
  is_glb.unique (is_glb_cInf ne (Exists.intro a (and.left H))) H

/-- A least element of a set is the infimum of this set. -/
theorem is_least.cInf_eq {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (H : is_least s a) : Inf s = a :=
  is_glb.cInf_eq (is_least.is_glb H) (is_least.nonempty H)

theorem subset_Icc_cInf_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (hb : bdd_below s) (ha : bdd_above s) : s ⊆ set.Icc (Inf s) (Sup s) :=
  fun (x : α) (hx : x ∈ s) => { left := cInf_le hb hx, right := le_cSup ha hx }

theorem cSup_le_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hb : bdd_above s) (ne : set.nonempty s) : Sup s ≤ a ↔ ∀ (b : α), b ∈ s → b ≤ a :=
  is_lub_le_iff (is_lub_cSup ne hb)

theorem le_cInf_iff {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hb : bdd_below s) (ne : set.nonempty s) : a ≤ Inf s ↔ ∀ (b : α), b ∈ s → a ≤ b :=
  le_is_glb_iff (is_glb_cInf ne hb)

theorem cSup_lower_bounds_eq_cInf {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (h : bdd_below s) (hs : set.nonempty s) : Sup (lower_bounds s) = Inf s :=
  is_lub.unique
    (is_lub_cSup h
      (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ lower_bounds s) => hy hx) hs))
    (is_greatest.is_lub (is_glb_cInf hs h))

theorem cInf_upper_bounds_eq_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (h : bdd_above s) (hs : set.nonempty s) : Inf (upper_bounds s) = Sup s :=
  is_glb.unique
    (is_glb_cInf h
      (set.nonempty.mono (fun (x : α) (hx : x ∈ s) (y : α) (hy : y ∈ upper_bounds s) => hy hx) hs))
    (is_least.is_glb (is_lub_cSup hs h))

/--Introduction rule to prove that b is the supremum of s: it suffices to check that b
is larger than all elements of s, and that this is not the case of any `w<b`.-/
theorem cSup_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α}
    (_x : set.nonempty s) :
    (∀ (a : α), a ∈ s → a ≤ b) → (∀ (w : α), w < b → ∃ (a : α), ∃ (H : a ∈ s), w < a) → Sup s = b :=
  sorry

/--Introduction rule to prove that b is the infimum of s: it suffices to check that b
is smaller than all elements of s, and that this is not the case of any `w>b`.-/
theorem cInf_intro {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {b : α}
    (_x : set.nonempty s) :
    (∀ (a : α), a ∈ s → b ≤ a) → (∀ (w : α), b < w → ∃ (a : α), ∃ (H : a ∈ s), a < w) → Inf s = b :=
  sorry

/--b < Sup s when there is an element a in s with b < a, when s is bounded above.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness above for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
theorem lt_cSup_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_above s) : a ∈ s → b < a → b < Sup s :=
  fun (_x_1 : a ∈ s) (_x_2 : b < a) => lt_of_lt_of_le _x_2 (le_cSup _x _x_1)

/--Inf s < b when there is an element a in s with a < b, when s is bounded below.
This is essentially an iff, except that the assumptions for the two implications are
slightly different (one needs boundedness below for one direction, nonemptiness and linear
order for the other one), so we formulate separately the two implications, contrary to
the complete_lattice case.-/
theorem cInf_lt_of_lt {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α} {b : α}
    (_x : bdd_below s) : a ∈ s → a < b → Inf s < b :=
  fun (_x_1 : a ∈ s) (_x_2 : a < b) => lt_of_le_of_lt (cInf_le _x _x_1) _x_2

/-- If all elements of a nonempty set `s` are less than or equal to all elements
of a nonempty set `t`, then there exists an element between these sets. -/
theorem exists_between_of_forall_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    {t : set α} (sne : set.nonempty s) (tne : set.nonempty t)
    (hst : ∀ (x : α), x ∈ s → ∀ (y : α), y ∈ t → x ≤ y) :
    set.nonempty (upper_bounds s ∩ lower_bounds t) :=
  Exists.intro (Inf t)
    { left := fun (x : α) (hx : x ∈ s) => le_cInf tne (hst x hx),
      right := fun (y : α) (hy : y ∈ t) => cInf_le (set.nonempty.mono hst sne) hy }

/--The supremum of a singleton is the element of the singleton-/
@[simp] theorem cSup_singleton {α : Type u_1} [conditionally_complete_lattice α] (a : α) :
    Sup (singleton a) = a :=
  is_greatest.cSup_eq is_greatest_singleton

/--The infimum of a singleton is the element of the singleton-/
@[simp] theorem cInf_singleton {α : Type u_1} [conditionally_complete_lattice α] (a : α) :
    Inf (singleton a) = a :=
  is_least.cInf_eq is_least_singleton

/--If a set is bounded below and above, and nonempty, its infimum is less than or equal to
its supremum.-/
theorem cInf_le_cSup {α : Type u_1} [conditionally_complete_lattice α] {s : set α}
    (hb : bdd_below s) (ha : bdd_above s) (ne : set.nonempty s) : Inf s ≤ Sup s :=
  is_glb_le_is_lub (is_glb_cInf ne hb) (is_lub_cSup ne ha) ne

/--The sup of a union of two sets is the max of the suprema of each subset, under the assumptions
that all sets are bounded above and nonempty.-/
theorem cSup_union {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (hs : bdd_above s) (sne : set.nonempty s) (ht : bdd_above t) (tne : set.nonempty t) :
    Sup (s ∪ t) = Sup s ⊔ Sup t :=
  is_lub.cSup_eq (is_lub.union (is_lub_cSup sne hs) (is_lub_cSup tne ht)) (set.nonempty.inl sne)

/--The inf of a union of two sets is the min of the infima of each subset, under the assumptions
that all sets are bounded below and nonempty.-/
theorem cInf_union {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (hs : bdd_below s) (sne : set.nonempty s) (ht : bdd_below t) (tne : set.nonempty t) :
    Inf (s ∪ t) = Inf s ⊓ Inf t :=
  is_glb.cInf_eq (is_glb.union (is_glb_cInf sne hs) (is_glb_cInf tne ht)) (set.nonempty.inl sne)

/--The supremum of an intersection of two sets is bounded by the minimum of the suprema of each
set, if all sets are bounded above and nonempty.-/
theorem cSup_inter_le {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_above s) : bdd_above t → set.nonempty (s ∩ t) → Sup (s ∩ t) ≤ Sup s ⊓ Sup t :=
  sorry

/--The infimum of an intersection of two sets is bounded below by the maximum of the
infima of each set, if all sets are bounded below and nonempty.-/
theorem le_cInf_inter {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {t : set α}
    (_x : bdd_below s) : bdd_below t → set.nonempty (s ∩ t) → Inf s ⊔ Inf t ≤ Inf (s ∩ t) :=
  sorry

/-- The supremum of insert a s is the maximum of a and the supremum of s, if s is
nonempty and bounded above.-/
theorem cSup_insert {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hs : bdd_above s) (sne : set.nonempty s) : Sup (insert a s) = a ⊔ Sup s :=
  is_lub.cSup_eq (is_lub.insert a (is_lub_cSup sne hs)) (set.insert_nonempty a s)

/-- The infimum of insert a s is the minimum of a and the infimum of s, if s is
nonempty and bounded below.-/
theorem cInf_insert {α : Type u_1} [conditionally_complete_lattice α] {s : set α} {a : α}
    (hs : bdd_below s) (sne : set.nonempty s) : Inf (insert a s) = a ⊓ Inf s :=
  is_glb.cInf_eq (is_glb.insert a (is_glb_cInf sne hs)) (set.insert_nonempty a s)

@[simp] theorem cInf_Ici {α : Type u_1} [conditionally_complete_lattice α] {a : α} :
    Inf (set.Ici a) = a :=
  is_least.cInf_eq is_least_Ici

@[simp] theorem cSup_Iic {α : Type u_1} [conditionally_complete_lattice α] {a : α} :
    Sup (set.Iic a) = a :=
  is_greatest.cSup_eq is_greatest_Iic

/--The indexed supremum of two functions are comparable if the functions are pointwise comparable-/
theorem csupr_le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    {g : ι → α} (B : bdd_above (set.range g)) (H : ∀ (x : ι), f x ≤ g x) : supr f ≤ supr g :=
  sorry

/--The indexed supremum of a function is bounded above by a uniform bound-/
theorem csupr_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι]
    {f : ι → α} {c : α} (H : ∀ (x : ι), f x ≤ c) : supr f ≤ c :=
  cSup_le (set.range_nonempty f)
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → b ≤ c)) (propext set.forall_range_iff)))
      H)

/--The indexed supremum of a function is bounded below by the value taken at one point-/
theorem le_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    (H : bdd_above (set.range f)) (c : ι) : f c ≤ supr f :=
  le_cSup H (set.mem_range_self c)

/--The indexed infimum of two functions are comparable if the functions are pointwise comparable-/
theorem cinfi_le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    {g : ι → α} (B : bdd_below (set.range f)) (H : ∀ (x : ι), f x ≤ g x) : infi f ≤ infi g :=
  sorry

/--The indexed minimum of a function is bounded below by a uniform lower bound-/
theorem le_cinfi {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [Nonempty ι]
    {f : ι → α} {c : α} (H : ∀ (x : ι), c ≤ f x) : c ≤ infi f :=
  le_cInf (set.range_nonempty f)
    (eq.mpr
      (id
        (Eq._oldrec (Eq.refl (∀ (b : α), b ∈ set.range f → c ≤ b)) (propext set.forall_range_iff)))
      H)

/--The indexed infimum of a function is bounded above by the value taken at one point-/
theorem cinfi_le {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] {f : ι → α}
    (H : bdd_below (set.range f)) (c : ι) : infi f ≤ f c :=
  cInf_le H (set.mem_range_self c)

@[simp] theorem cinfi_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α]
    [hι : Nonempty ι] {a : α} : (infi fun (b : ι) => a) = a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((infi fun (b : ι) => a) = a)) (infi.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Inf (singleton a) = a)) (cInf_singleton a))) (Eq.refl a)))

@[simp] theorem csupr_const {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α]
    [hι : Nonempty ι] {a : α} : (supr fun (b : ι) => a) = a :=
  eq.mpr
    (id
      (Eq._oldrec (Eq.refl ((supr fun (b : ι) => a) = a)) (supr.equations._eqn_1 fun (b : ι) => a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (set.range fun (b : ι) => a) = a)) set.range_const))
      (eq.mpr (id (Eq._oldrec (Eq.refl (Sup (singleton a) = a)) (cSup_singleton a))) (Eq.refl a)))

theorem infi_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι]
    {s : ι → α} : (infi fun (i : ι) => s i) = s Inhabited.default :=
  sorry

theorem supr_unique {α : Type u_1} {ι : Sort u_3} [conditionally_complete_lattice α] [unique ι]
    {s : ι → α} : (supr fun (i : ι) => s i) = s Inhabited.default :=
  sorry

@[simp] theorem infi_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} :
    (infi fun (x : Unit) => f x) = f Unit.unit :=
  sorry

@[simp] theorem supr_unit {α : Type u_1} [conditionally_complete_lattice α] {f : Unit → α} :
    (supr fun (x : Unit) => f x) = f Unit.unit :=
  sorry

/-- Nested intervals lemma: if `f` is a monotonically increasing sequence, `g` is a monotonically
decreasing sequence, and `f n ≤ g n` for all `n`, then `⨆ n, f n` belongs to all the intervals
`[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr {α : Type u_1} {β : Type u_2}
    [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α}
    (hf : monotone f) (hg : ∀ {m n : β}, m ≤ n → g n ≤ g m) (h : ∀ (n : β), f n ≤ g n) :
    (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) :=
  sorry

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc {α : Type u_1} {β : Type u_2}
    [conditionally_complete_lattice α] [Nonempty β] [semilattice_sup β] {f : β → α} {g : β → α}
    (h : ∀ {m n : β}, m ≤ n → set.Icc (f n) (g n) ⊆ set.Icc (f m) (g m))
    (h' : ∀ (n : β), f n ≤ g n) :
    (supr fun (n : β) => f n) ∈ set.Inter fun (n : β) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_incr_of_mono_decr
    (fun (m n : β) (hmn : m ≤ n) => and.left (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn)))
    (fun (m n : β) (hmn : m ≤ n) => and.right (iff.mp (set.Icc_subset_Icc_iff (h' n)) (h hmn))) h'

/-- Nested intervals lemma: if `[f n, g n]` is a monotonically decreasing sequence of nonempty
closed intervals, then `⨆ n, f n` belongs to all the intervals `[f n, g n]`. -/
theorem csupr_mem_Inter_Icc_of_mono_decr_Icc_nat {α : Type u_1} [conditionally_complete_lattice α]
    {f : ℕ → α} {g : ℕ → α} (h : ∀ (n : ℕ), set.Icc (f (n + 1)) (g (n + 1)) ⊆ set.Icc (f n) (g n))
    (h' : ∀ (n : ℕ), f n ≤ g n) :
    (supr fun (n : ℕ) => f n) ∈ set.Inter fun (n : ℕ) => set.Icc (f n) (g n) :=
  csupr_mem_Inter_Icc_of_mono_decr_Icc (monotone_of_monotone_nat h) h'

protected instance pi.conditionally_complete_lattice {ι : Type u_1} {α : ι → Type u_2}
    [(i : ι) → conditionally_complete_lattice (α i)] :
    conditionally_complete_lattice ((i : ι) → α i) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- When b < Sup s, there is an element a in s with b < a, if s is nonempty and the order is
a linear order. -/
theorem exists_lt_of_lt_cSup {α : Type u_1} [conditionally_complete_linear_order α] {s : set α}
    {b : α} (hs : set.nonempty s) (hb : b < Sup s) : ∃ (a : α), ∃ (H : a ∈ s), b < a :=
  sorry

/--
Indexed version of the above lemma `exists_lt_of_lt_cSup`.
When `b < supr f`, there is an element `i` such that `b < f i`.
-/
theorem exists_lt_of_lt_csupr {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α]
    {b : α} [Nonempty ι] {f : ι → α} (h : b < supr f) : ∃ (i : ι), b < f i :=
  sorry

/--When Inf s < b, there is an element a in s with a < b, if s is nonempty and the order is
a linear order.-/
theorem exists_lt_of_cInf_lt {α : Type u_1} [conditionally_complete_linear_order α] {s : set α}
    {b : α} (hs : set.nonempty s) (hb : Inf s < b) : ∃ (a : α), ∃ (H : a ∈ s), a < b :=
  sorry

/--
Indexed version of the above lemma `exists_lt_of_cInf_lt`
When `infi f < a`, there is an element `i` such that `f i < a`.
-/
theorem exists_lt_of_cinfi_lt {α : Type u_1} {ι : Sort u_3} [conditionally_complete_linear_order α]
    {a : α} [Nonempty ι] {f : ι → α} (h : infi f < a) : ∃ (i : ι), f i < a :=
  sorry

/--Introduction rule to prove that b is the supremum of s: it suffices to check that
1) b is an upper bound
2) every other upper bound b' satisfies b ≤ b'.-/
theorem cSup_intro' {α : Type u_1} [conditionally_complete_linear_order α] {s : set α} {b : α}
    (_x : set.nonempty s) (h_is_ub : ∀ (a : α), a ∈ s → a ≤ b)
    (h_b_le_ub : ∀ (ub : α), (∀ (a : α), a ∈ s → a ≤ ub) → b ≤ ub) : Sup s = b :=
  le_antisymm ((fun (this : Sup s ≤ b) => this) (cSup_le _x h_is_ub))
    ((fun (this : b ≤ Sup s) => this)
      (h_b_le_ub (Sup s) fun (a : α) => le_cSup (Exists.intro b h_is_ub)))

theorem cSup_empty {α : Type u_1} [conditionally_complete_linear_order_bot α] : Sup ∅ = ⊥ :=
  conditionally_complete_linear_order_bot.cSup_empty

namespace nat

protected instance has_Inf : has_Inf ℕ :=
  has_Inf.mk
    fun (s : set ℕ) =>
      dite (∃ (n : ℕ), n ∈ s) (fun (h : ∃ (n : ℕ), n ∈ s) => nat.find h)
        fun (h : ¬∃ (n : ℕ), n ∈ s) => 0

protected instance has_Sup : has_Sup ℕ :=
  has_Sup.mk
    fun (s : set ℕ) =>
      dite (∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n)
        (fun (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => nat.find h)
        fun (h : ¬∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) => 0

theorem Inf_def {s : set ℕ} (h : set.nonempty s) : Inf s = nat.find h := dif_pos h

theorem Sup_def {s : set ℕ} (h : ∃ (n : ℕ), ∀ (a : ℕ), a ∈ s → a ≤ n) : Sup s = nat.find h :=
  dif_pos h

@[simp] theorem Inf_eq_zero {s : set ℕ} : Inf s = 0 ↔ 0 ∈ s ∨ s = ∅ := sorry

theorem Inf_mem {s : set ℕ} (h : set.nonempty s) : Inf s ∈ s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ∈ s)) (Inf_def h))) (nat.find_spec h)

theorem not_mem_of_lt_Inf {s : set ℕ} {m : ℕ} (hm : m < Inf s) : ¬m ∈ s :=
  or.dcases_on (set.eq_empty_or_nonempty s)
    (fun (h : s = ∅) => Eq._oldrec (fun (hm : m < Inf ∅) => set.not_mem_empty m) (Eq.symm h) hm)
    fun (h : set.nonempty s) =>
      nat.find_min h (eq.mp (Eq._oldrec (Eq.refl (m < Inf s)) (Inf_def h)) hm)

protected theorem Inf_le {s : set ℕ} {m : ℕ} (hm : m ∈ s) : Inf s ≤ m :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Inf s ≤ m)) (Inf_def (Exists.intro m hm))))
    (nat.find_min' (Exists.intro m hm) hm)

/-- This instance is necessary, otherwise the lattice operations would be derived via
conditionally_complete_linear_order_bot and marked as noncomputable. -/
protected instance lattice : lattice ℕ := Mathlib.lattice_of_linear_order

protected instance conditionally_complete_linear_order_bot :
    conditionally_complete_linear_order_bot ℕ :=
  conditionally_complete_linear_order_bot.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry
    sorry sorry sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt order_bot.bot
    sorry sorry

end nat

namespace with_top

/-- The Sup of a non-empty set is its least upper bound for a conditionally
complete lattice with a top. -/
theorem is_lub_Sup' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)}
    (hs : set.nonempty s) : is_lub s (Sup s) :=
  sorry

theorem is_lub_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α]
    (s : set (with_top α)) : is_lub s (Sup s) :=
  sorry

/-- The Inf of a bounded-below set is its greatest lower bound for a conditionally
complete lattice with a top. -/
theorem is_glb_Inf' {β : Type u_1} [conditionally_complete_lattice β] {s : set (with_top β)}
    (hs : bdd_below s) : is_glb s (Inf s) :=
  sorry

theorem is_glb_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α]
    (s : set (with_top α)) : is_glb s (Inf s) :=
  dite (bdd_below s) (fun (hs : bdd_below s) => is_glb_Inf' hs)
    fun (hs : ¬bdd_below s) =>
      False._oldrec (hs (Exists.intro ⊥ (id (id fun (a : with_top α) (ᾰ : a ∈ s) => bot_le))))

protected instance complete_linear_order {α : Type u_1}
    [conditionally_complete_linear_order_bot α] : complete_linear_order (with_top α) :=
  complete_linear_order.mk lattice.sup linear_order.le linear_order.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry order_top.top sorry order_bot.bot sorry Sup Inf sorry sorry
    sorry sorry sorry (classical.dec_rel LessEq) linear_order.decidable_eq linear_order.decidable_lt

theorem coe_Sup {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α}
    (hb : bdd_above s) : ↑(Sup s) = supr fun (a : α) => supr fun (H : a ∈ s) => ↑a :=
  sorry

theorem coe_Inf {α : Type u_1} [conditionally_complete_linear_order_bot α] {s : set α}
    (hs : set.nonempty s) : ↑(Inf s) = infi fun (a : α) => infi fun (H : a ∈ s) => ↑a :=
  sorry

end with_top

namespace enat

protected instance complete_linear_order : complete_linear_order enat :=
  complete_linear_order.mk bounded_lattice.sup linear_order.le linear_order.lt linear_order.le_refl
    linear_order.le_trans linear_order.le_antisymm bounded_lattice.le_sup_left
    bounded_lattice.le_sup_right bounded_lattice.sup_le bounded_lattice.inf
    bounded_lattice.inf_le_left bounded_lattice.inf_le_right bounded_lattice.le_inf
    bounded_lattice.top bounded_lattice.le_top bounded_lattice.bot bounded_lattice.bot_le
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Sup (⇑with_top_equiv '' s)))
    (fun (s : set enat) => coe_fn (equiv.symm with_top_equiv) (Inf (⇑with_top_equiv '' s))) sorry
    sorry sorry sorry linear_order.le_total linear_order.decidable_le linear_order.decidable_eq
    linear_order.decidable_lt

end enat

protected instance order_dual.conditionally_complete_lattice (α : Type u_1)
    [conditionally_complete_lattice α] : conditionally_complete_lattice (order_dual α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf cInf_le le_cInf le_cSup cSup_le

protected instance order_dual.conditionally_complete_linear_order (α : Type u_1)
    [conditionally_complete_linear_order α] : conditionally_complete_linear_order (order_dual α) :=
  conditionally_complete_linear_order.mk conditionally_complete_lattice.sup
    conditionally_complete_lattice.le conditionally_complete_lattice.lt sorry sorry sorry sorry
    sorry sorry conditionally_complete_lattice.inf sorry sorry sorry
    conditionally_complete_lattice.Sup conditionally_complete_lattice.Inf sorry sorry sorry sorry
    sorry linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

namespace monotone

/-! A monotone function into a conditionally complete lattice preserves the ordering properties of
`Sup` and `Inf`. -/

theorem le_cSup_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_above s) :
    f c ≤ Sup (f '' s) :=
  le_cSup (map_bdd_above h_mono h_bdd) (set.mem_image_of_mem f hcs)

theorem cSup_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α}
    (hB : B ∈ upper_bounds s) : Sup (f '' s) ≤ f B :=
  cSup_le (set.nonempty.image f hs) (mem_upper_bounds_image h_mono hB)

theorem cInf_image_le {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} {c : α} (hcs : c ∈ s) (h_bdd : bdd_below s) :
    Inf (f '' s) ≤ f c :=
  le_cSup_image (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hcs h_bdd

theorem le_cInf_image {α : Type u_1} {β : Type u_2} [preorder α] [conditionally_complete_lattice β]
    {f : α → β} (h_mono : monotone f) {s : set α} (hs : set.nonempty s) {B : α}
    (hB : B ∈ lower_bounds s) : f B ≤ Inf (f '' s) :=
  cSup_image_le (fun (x y : order_dual α) (hxy : x ≤ y) => h_mono hxy) hs hB

end monotone

/-!
### Complete lattice structure on `with_top (with_bot α)`

If `α` is a `conditionally_complete_lattice`, then we show that `with_top α` and `with_bot α`
also inherit the structure of conditionally complete lattices. Furthermore, we show
that `with_top (with_bot α)` naturally inherits the structure of a complete lattice. Note that
for α a conditionally complete lattice, `Sup` and `Inf` both return junk values
for sets which are empty or unbounded. The extension of `Sup` to `with_top α` fixes
the unboundedness problem and the extension to `with_bot α` fixes the problem with
the empty set.

This result can be used to show that the extended reals [-∞, ∞] are a complete lattice.
-/

/-- Adding a top element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_top.conditionally_complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : conditionally_complete_lattice (with_top α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom element to a conditionally complete lattice gives a conditionally complete lattice -/
protected instance with_bot.conditionally_complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : conditionally_complete_lattice (with_bot α) :=
  conditionally_complete_lattice.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry sorry
    sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry

/-- Adding a bottom and a top to a conditionally complete lattice gives a bounded lattice-/
protected instance with_top.with_bot.bounded_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : bounded_lattice (with_top (with_bot α)) :=
  bounded_lattice.mk lattice.sup order_bot.le order_bot.lt sorry sorry sorry sorry sorry sorry
    lattice.inf sorry sorry sorry order_top.top sorry order_bot.bot sorry

theorem with_bot.cSup_empty {α : Type u_1} [conditionally_complete_lattice α] : Sup ∅ = ⊥ := sorry

protected instance with_top.with_bot.complete_lattice {α : Type u_1}
    [conditionally_complete_lattice α] : complete_lattice (with_top (with_bot α)) :=
  complete_lattice.mk bounded_lattice.sup bounded_lattice.le bounded_lattice.lt sorry sorry sorry
    sorry sorry sorry bounded_lattice.inf sorry sorry sorry bounded_lattice.top sorry
    bounded_lattice.bot sorry Sup Inf sorry sorry sorry sorry

/-! ### Subtypes of conditionally complete linear orders

In this section we give conditions on a subset of a conditionally complete linear order, to ensure
that the subtype is itself conditionally complete.

We check that an `ord_connected` set satisfies these conditions.

TODO There are several possible variants; the `conditionally_complete_linear_order` could be changed
to `conditionally_complete_linear_order_bot` or `complete_linear_order`.
-/

/-- `has_Sup` structure on a nonempty subset `s` of an object with `has_Sup`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Sup {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] : has_Sup ↥s :=
  has_Sup.mk
    fun (t : set ↥s) =>
      dite (Sup (coe '' t) ∈ s)
        (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
        fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Sup_def {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] :
    Sup =
        fun (t : set ↥s) =>
          dite (Sup (coe '' t) ∈ s)
            (fun (ht : Sup (coe '' t) ∈ s) => { val := Sup (coe '' t), property := ht })
            fun (ht : ¬Sup (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Sup_of_within {α : Type u_1} (s : set α) [has_Sup α] [Inhabited ↥s] {t : set ↥s}
    (h : Sup (coe '' t) ∈ s) : Sup (coe '' t) = ↑(Sup t) :=
  sorry

/-- `has_Inf` structure on a nonempty subset `s` of an object with `has_Inf`. This definition is
non-canonical (it uses `default s`); it should be used only as here, as an auxiliary instance in the
construction of the `conditionally_complete_linear_order` structure. -/
def subset_has_Inf {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] : has_Inf ↥s :=
  has_Inf.mk
    fun (t : set ↥s) =>
      dite (Inf (coe '' t) ∈ s)
        (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
        fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default

@[simp] theorem subset_Inf_def {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] :
    Inf =
        fun (t : set ↥s) =>
          dite (Inf (coe '' t) ∈ s)
            (fun (ht : Inf (coe '' t) ∈ s) => { val := Inf (coe '' t), property := ht })
            fun (ht : ¬Inf (coe '' t) ∈ s) => Inhabited.default :=
  rfl

theorem subset_Inf_of_within {α : Type u_1} (s : set α) [has_Inf α] [Inhabited ↥s] {t : set ↥s}
    (h : Inf (coe '' t) ∈ s) : Inf (coe '' t) = ↑(Inf t) :=
  sorry

/-- For a nonempty subset of a conditionally complete linear order to be a conditionally complete
linear order, it suffices that it contain the `Sup` of all its nonempty bounded-above subsets, and
the `Inf` of all its nonempty bounded-below subsets. -/
def subset_conditionally_complete_linear_order {α : Type u_1} (s : set α)
    [conditionally_complete_linear_order α] [Inhabited ↥s]
    (h_Sup : ∀ {t : set ↥s}, set.nonempty t → bdd_above t → Sup (coe '' t) ∈ s)
    (h_Inf : ∀ {t : set ↥s}, set.nonempty t → bdd_below t → Inf (coe '' t) ∈ s) :
    conditionally_complete_linear_order ↥s :=
  conditionally_complete_linear_order.mk lattice.sup lattice.le lattice.lt sorry sorry sorry sorry
    sorry sorry lattice.inf sorry sorry sorry Sup Inf sorry sorry sorry sorry sorry
    linear_order.decidable_le linear_order.decidable_eq linear_order.decidable_lt

/-- The `Sup` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-above subsets of `s`. -/
theorem Sup_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α]
    {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t)
    (h_bdd : bdd_above t) : Sup (coe '' t) ∈ s :=
  sorry

/-- The `Inf` function on a nonempty `ord_connected` set `s` in a conditionally complete linear
order takes values within `s`, for all nonempty bounded-below subsets of `s`. -/
theorem Inf_within_of_ord_connected {α : Type u_1} [conditionally_complete_linear_order α]
    {s : set α} [hs : set.ord_connected s] {t : set ↥s} (ht : set.nonempty t)
    (h_bdd : bdd_below t) : Inf (coe '' t) ∈ s :=
  sorry

/-- A nonempty `ord_connected` set in a conditionally complete linear order is naturally a
conditionally complete linear order. -/
protected instance ord_connected_subset_conditionally_complete_linear_order {α : Type u_1}
    (s : set α) [conditionally_complete_linear_order α] [Inhabited ↥s] [set.ord_connected s] :
    conditionally_complete_linear_order ↥s :=
  subset_conditionally_complete_linear_order s Sup_within_of_ord_connected
    Inf_within_of_ord_connected

end Mathlib


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.hint
import Mathlib.PostPort

namespace Mathlib

namespace tactic

/--
  find all assumptions of the shape `¬ (p ∧ q)` or `¬ (p ∨ q)` and
  replace them using de Morgan's law.
-/
/-!
  The following definitions maintain a path compression datastructure, i.e. a forest such that:
    - every node is the type of a hypothesis
    - there is a edge between two nodes only if they are provably equivalent
    - every edge is labelled with a proof of equivalence for its vertices
    - edges are added when normalizing propositions.
-/

/--
  If there exists a symmetry lemma that can be applied to the hypothesis `e`,
  store it.
-/
/--
  Retrieve the root of the hypothesis `e` from the proof forest.
  If `e` has not been internalized, add it to the proof forest.
-/
/--
  Given hypotheses `a` and `b`, build a proof that `a` is equivalent to `b`,
  applying congruence and recursing into arguments if `a` and `b`
  are applications of function symbols.
-/
/--
  Configuration options for `tauto`.
  If `classical` is `tt`, runs `classical` before the rest of `tauto`.
  `closer` is run on any remaining subgoals left by `tauto_core; basic_tauto_tacs`.
-/
namespace interactive

/--
`tautology` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tautology!` uses the law of excluded middle.

`tautology {closer := tac}` will use `tac` on any subgoals created by `tautology`
that it is unable to solve before failing.
-/
-- Now define a shorter name for the tactic `tautology`.

/--
`tauto` breaks down assumptions of the form `_ ∧ _`, `_ ∨ _`, `_ ↔ _` and `∃ _, _`
and splits a goal of the form `_ ∧ _`, `_ ↔ _` or `∃ _, _` until it can be discharged
using `reflexivity` or `solve_by_elim`.
This is a finishing tactic: it either closes the goal or raises an error.
The variant `tauto!` uses the law of excluded middle.

`tauto {closer := tac}` will use `tac` on any subgoals created by `tauto`
that it is unable to solve before failing.
-/
/--
This tactic (with shorthand `tauto`) breaks down assumptions of the form
end Mathlib


/-
Copied and modified from Lean 4 `./src/Lean/PrettyPrinter/Delaborator/Builtins.lean`
-/
import Lean
import LeanCodePrompts.Utils
open Lean Meta Elab Term Parser PrettyPrinter
/-!
# Verbose delaborators

We define delaborators that preserve more information than the default ones, and corresponding syntax to allow this.
-/
namespace LeanAide.Meta

open Elab Term in
/-- Syntax `proof =: prop` for a proof with its type recorded -/
elab (name:=proved_prop) "(" a:term "=:" b:term ")": term => do
    let b ← elabType b
    let a ← elabTermEnsuringType a (some b)
    guard (← isProof a)
    return a

example :=  ((by decide) =: 1 ≤ 2 )

open Delaborator SubExpr
def checkExprDepth (e: Expr) : DelabM Unit := do
  let depth ← getDelabBound
  if e.approxDepth > depth then
    failure

def checkDepth : DelabM Unit := do
  let depth ← getDelabBound
  let e ← getExpr
  if e.approxDepth > depth then
    failure

/-- Modified top-level delaborator to expand if proof to `proof =: prop`-/
partial def delabVerbose : Delab := do
  checkMaxHeartbeats "delab"
  let e ← getExpr
  let isProof := !e.isAtomic && (← (try Meta.isProof e catch _ => pure false))
  let k ← getExprKind
  let stx ← delabFor k <|> (liftM $ show MetaM _ from throwError "don't know how to delaborate '{k}'")
  if (← getPPOption getPPAnalyzeTypeAscriptions <&&> getPPOption getPPAnalysisNeedsType <&&> pure !e.isMData) then
    let typeStx ← withType delab
    `(($stx : $typeStx)) >>= annotateCurPos
  else if isProof then
    let typeStx ← withType delab
    `(($stx =: $typeStx)) >>= annotateCurPos
  else
    return stx

/-- Helper wrapping a proof `proof` as `proof =: prop` -/
def wrapInType (e: Expr)(stx: Term) : Delab := do
  let isProof ← (try Meta.isProof e catch _ => pure false)
  if isProof then
    let typeStx ← withType delab
    `(($stx =: $typeStx)) >>= annotateCurPos
  else
    return stx

open Lean.Parser.Term
open TSyntax.Compat

def fvarPrefix : Name := "freeVariable"

@[delab app]
def delabAppExplicitVerbose : Delab := do
  checkDepth
  let paramKinds ← getParamKinds
  let tagAppFn ← getPPOption getPPTagAppFns
  let (fnStx, _, argStxs) ← withAppFnArgs
    (do
      let stx ← withOptionAtCurrPos `pp.tagAppFns tagAppFn delabAppFn
      let needsExplicit := stx.raw.getKind != ``Lean.Parser.Term.explicit
      let stx ← if needsExplicit then `(@$stx) else pure stx
      pure (stx, paramKinds.toList, #[]))
    (fun ⟨fnStx, paramKinds, argStxs⟩ => do
      let isInstImplicit := match paramKinds with
                            | [] => false
                            | param :: _ => param.bInfo == BinderInfo.instImplicit
      let argStx ← if ← getPPOption getPPAnalysisHole then `(_)
                   else if isInstImplicit == true then
                     let stx ← if ← getPPOption getPPInstances then delab else `(_)
                     if ← getPPOption getPPInstanceTypes then
                       let typeStx ← withType delab
                       `(($stx : $typeStx))
                     else pure stx
                   else delabVerbose
      pure (fnStx, paramKinds.tailD [], argStxs.push argStx))
  let stx := Syntax.mkApp fnStx argStxs
  wrapInType (← getExpr) stx

@[delab app]
def delabAppImplicit : Delab := do
  checkDepth
  -- TODO: always call the unexpanders, make them guard on the right # args?
  let paramKinds ← getParamKinds
  if ← getPPOption getPPExplicit then
    if paramKinds.any (fun param => !param.isRegularExplicit) then failure

  -- If the application has an implicit function type, fall back to delabAppExplicit.
  -- This is e.g. necessary for `@Eq`.
  let isImplicitApp ← try
      let ty ← whnf (← inferType (← getExpr))
      pure <| ty.isForall && (ty.binderInfo == BinderInfo.implicit || ty.binderInfo == BinderInfo.instImplicit)
    catch _ => pure false
  if isImplicitApp then failure

  let tagAppFn ← getPPOption getPPTagAppFns
  let (fnStx, _, argStxs) ← withAppFnArgs
    (withOptionAtCurrPos `pp.tagAppFns tagAppFn <|
      return (← delabAppFn, paramKinds.toList, #[]))
    (fun (fnStx, paramKinds, argStxs) => do
      let arg ← getExpr
      let opts ← getOptions
      let mkNamedArg (name : Name) (argStx : Syntax) : DelabM Syntax := do
        `(Parser.Term.namedArgument| ($(mkIdent name) := $argStx))
      let argStx? : Option Syntax ←
        if ← getPPOption getPPAnalysisSkip then pure none
        else if ← getPPOption getPPAnalysisHole then `(_)
        else
          match paramKinds with
          | [] => delabVerbose
          | param :: rest =>
            if param.defVal.isSome && rest.isEmpty then
              let v := param.defVal.get!
              if !v.hasLooseBVars && v == arg then pure none else delabVerbose
            else if !param.isRegularExplicit && param.defVal.isNone then
              if ← getPPOption getPPAnalysisNamedArg <||> (pure (param.name == `motive) <&&> shouldShowMotive arg opts) then some <$> mkNamedArg param.name (← delabVerbose) else pure none
            else delabVerbose
      let argStxs := match argStx? with
        | none => argStxs
        | some stx => argStxs.push stx
      pure (fnStx, paramKinds.tailD [], argStxs))
  let stx := Syntax.mkApp fnStx argStxs
  let stx ← wrapInType (← getExpr) stx
  if ← isRegularApp then
    (guard (← getPPOption getPPNotation) *> unexpandRegularApp stx)
    <|> (guard (← getPPOption getPPStructureInstances) *> unexpandStructureInstance stx)
    <|> pure stx
  else pure stx

/--
  Extract arguments of motive applications from the matcher type.
  For the example below: `#[#[`([])], #[`(a::as)]]` -/
private partial def delabPatterns (st : AppMatchState) : DelabM (Array (Array Term)) :=
  withReader (fun ctx => { ctx with inPattern := true, optionsPerPos := {} }) do
    let ty ← instantiateForall st.matcherTy st.params
    -- need to reduce `let`s that are lifted into the matcher type
    forallTelescopeReducing ty fun params _ => do
      -- skip motive and discriminators
      let alts := Array.ofSubarray params[1 + st.discrs.size:]
      alts.mapIdxM fun idx alt => do
        let ty ← inferType alt
        -- TODO: this is a hack; we are accessing the expression out-of-sync with the position
        -- Currently, we reset `optionsPerPos` at the beginning of `delabPatterns` to avoid
        -- incorrectly considering annotations.
        withTheReader SubExpr ({ · with expr := ty }) $
          usingNames st.varNames[idx]! do
            withAppFnArgs (pure #[]) (fun pats => do pure $ pats.push (← delabVerbose))
where
  usingNames {α} (varNames : Array Name) (x : DelabM α) : DelabM α :=
    usingNamesAux 0 varNames x
  usingNamesAux {α} (i : Nat) (varNames : Array Name) (x : DelabM α) : DelabM α :=
    if i < varNames.size then
      withBindingBody varNames[i]! <| usingNamesAux (i+1) varNames x
    else
      x

/-- Skip `numParams` binders, and execute `x varNames` where `varNames` contains the new binder names. -/
private partial def skippingBinders {α} (numParams : Nat) (x : Array Name → DelabM α) : DelabM α :=
  loop numParams #[]
where
  loop : Nat → Array Name → DelabM α
    | 0,   varNames => x varNames
    | n+1, varNames => do
      let rec visitLambda : DelabM α := do
        let varName := (← getExpr).bindingName!.eraseMacroScopes
        -- Pattern variables cannot shadow each other
        if varNames.contains varName then
          let varName := (← getLCtx).getUnusedName varName
          withBindingBody varName do
            loop n (varNames.push varName)
        else
          withBindingBodyUnusedName fun id => do
            loop n (varNames.push id.getId)
      let e ← getExpr
      if e.isLambda then
        visitLambda
      else
        -- eta expand `e`
        let e ← forallTelescopeReducing (← inferType e) fun xs _ => do
          if xs.size == 1 && (← inferType xs[0]!).isConstOf ``Unit then
            -- `e` might be a thunk create by the dependent pattern matching compiler, and `xs[0]` may not even be a pattern variable.
            -- If it is a pattern variable, it doesn't look too bad to use `()` instead of the pattern variable.
            -- If it becomes a problem in the future, we should modify the dependent pattern matching compiler, and make sure
            -- it adds an annotation to distinguish these two cases.
            mkLambdaFVars xs (mkApp e (mkConst ``Unit.unit))
          else
            mkLambdaFVars xs (mkAppN e xs)
        withTheReader SubExpr (fun ctx => { ctx with expr := e }) visitLambda

/--
  Delaborate applications of "matchers" such as
  ```
  List.map.match_1 : {α : Type _} →
    (motive : List α → Sort _) →
      (x : List α) → (Unit → motive List.nil) → ((a : α) → (as : List α) → motive (a :: as)) → motive x
  ```
-/
@[delab app]
def delabAppMatch : Delab := whenPPOption getPPNotation <| whenPPOption getPPMatch do
  checkDepth
  -- incrementally fill `AppMatchState` from arguments
  let st ← withAppFnArgs
    (do
      let (Expr.const c us) ← getExpr | failure
      let (some info) ← getMatcherInfo? c | failure
      let matcherTy ← instantiateTypeLevelParams (← getConstInfo c) us
      return { matcherTy, info : AppMatchState })
    (fun st => do
      if st.params.size < st.info.numParams then
        return { st with params := st.params.push (← getExpr) }
      else if st.motive.isNone then
        -- store motive argument separately
        let lamMotive ← getExpr
        let piMotive ← lambdaTelescope lamMotive fun xs body => mkForallFVars xs body
        -- TODO: pp.analyze has not analyzed `piMotive`, only `lamMotive`
        -- Thus the binder types won't have any annotations
        let piStx ← withTheReader SubExpr (fun cfg => { cfg with expr := piMotive }) delabVerbose
        let named ← getPPOption getPPAnalysisNamedArg
        return { st with motive := (piStx, lamMotive), motiveNamed := named }
      else if st.discrs.size < st.info.numDiscrs then
        let idx := st.discrs.size
        let discr ← delabVerbose
        if let some hName := st.info.discrInfos[idx]!.hName? then
          -- TODO: we should check whether the corresponding binder name, matches `hName`.
          -- If it does not we should pretty print this `match` as a regular application.
          return { st with discrs := st.discrs.push (← `(matchDiscr| $(mkIdent hName) : $discr)) }
        else
          return { st with discrs := st.discrs.push (← `(matchDiscr| $discr:term)) }
      else if st.rhss.size < st.info.altNumParams.size then
        /- We save the variables names here to be able to implement safe_shadowing.
           The pattern delaboration must use the names saved here. -/
        let (varNames, rhs) ← skippingBinders st.info.altNumParams[st.rhss.size]! fun varNames => do
          let rhs ← delabVerbose
          return (varNames, rhs)
        return { st with rhss := st.rhss.push rhs, varNames := st.varNames.push varNames }
      else
        return { st with moreArgs := st.moreArgs.push (← delabVerbose) })

  if st.discrs.size < st.info.numDiscrs || st.rhss.size < st.info.altNumParams.size then
    -- underapplied
    failure

  match st.discrs, st.rhss with
  | #[discr], #[] =>
    let stx ← `(nomatch $discr)
    return Syntax.mkApp stx st.moreArgs
  | _,        #[] => failure
  | _,        _   =>
    let pats ← delabPatterns st
    let stx ← do
      let (piStx, lamMotive) := st.motive.get!
      let opts ← getOptions
      -- TODO: disable the match if other implicits are needed?
      if ← pure st.motiveNamed <||> shouldShowMotive lamMotive opts then
        `(match (motive := $piStx) $[$st.discrs:matchDiscr],* with $[| $pats,* => $st.rhss]*)
      else
        `(match $[$st.discrs:matchDiscr],* with $[| $pats,* => $st.rhss]*)
    return Syntax.mkApp stx st.moreArgs

/--
  Delaborate applications of the form `(fun x => b) v` as `let_fun x := v; b`
-/
def delabLetFun : Delab := do
  let stxV ← withAppArg delabVerbose
  withAppFn do
    let Expr.lam n _ b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxB ← withBindingBody n delabVerbose
    if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
      let stxT ← withBindingDomain delab
      `(let_fun $(mkIdent n) : $stxT := $stxV; $stxB)
    else
      `(let_fun $(mkIdent n) := $stxV; $stxB)

@[delab mdata]
def delabMData : Delab := do
  -- checkDepth
  if let some _ := inaccessible? (← getExpr) then
    let s ← withMDataExpr delabVerbose
    if (← read).inPattern then
      `(.($s)) -- We only include the inaccessible annotation when we are delaborating patterns
    else
      return s
  else if isLetFun (← getExpr) && getPPNotation (← getOptions) then
    withMDataExpr <| delabLetFun
  else if let some _ := isLHSGoal? (← getExpr) then
    withMDataExpr <| withAppFn <| withAppArg <| delabVerbose
  else
    withMDataOptions delabVerbose

/--
Check for a `Syntax.ident` of the given name anywhere in the tree.
This is usually a bad idea since it does not check for shadowing bindings,
but in the delaborator we assume that bindings are never shadowed.
-/
partial def hasIdent (id : Name) : Syntax → Bool
  | Syntax.ident _ _ id' _ => id == id'
  | Syntax.node _ _ args   => args.any (hasIdent id)
  | _                      => false

/--
Return `true` iff current binder should be merged with the nested
binder, if any, into a single binder group:
* both binders must have same binder info and domain
* they cannot be inst-implicit (`[a b : A]` is not valid syntax)
* `pp.binderTypes` must be the same value for both terms
* prefer `fun a b` over `fun (a b)`
-/
private def shouldGroupWithNext : DelabM Bool := do
  let e ← getExpr
  let ppEType ← getPPOption (getPPBinderTypes e)
  let go (e' : Expr) := do
    let ppE'Type ← withBindingBody `_ $ getPPOption (getPPBinderTypes e)
    pure $ e.binderInfo == e'.binderInfo &&
      e.bindingDomain! == e'.bindingDomain! &&
      e'.binderInfo != BinderInfo.instImplicit &&
      ppEType == ppE'Type &&
      (e'.binderInfo != BinderInfo.default || ppE'Type)
  match e with
  | Expr.lam _ _     e'@(Expr.lam _ _ _ _) _     => go e'
  | Expr.forallE _ _ e'@(Expr.forallE _ _ _ _) _ => go e'
  | _ => pure false
where
  getPPBinderTypes (e : Expr) :=
    if e.isForall then getPPPiBinderTypes else getPPFunBinderTypes

def withBindingBodyUnusedName {α} (d : Syntax → DelabM α) : DelabM α := do
  let n ← getUnusedName (← getExpr).bindingName! (← getExpr).bindingBody!
  -- let n := n.append "domVar"
  let stxN ← annotateCurPos (mkIdent n)
  withBindingBody n $ d stxN

/-- `delabBinders` modified to never group -/
private partial def delabBinders (delabGroup : Array Syntax → Syntax → Delab) : optParam (Array Syntax) #[] → Delab
  | curNames => do
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => return (← delab, stxN)
      delabGroup (curNames.push stxN) stx

/-- `delabLam` modified to always have type info and never group -/
@[delab lam]
def delabLam : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let stxT ← withBindingDomain delab
    let ppTypes := true
    let usedDownstream := curNames.any (fun n => hasIdent n.getId stxBody)

    let blockImplicitLambda := true

    if !blockImplicitLambda then
      pure stxBody -- empty case
    else
      let defaultCase (_ : Unit) : Delab := do
        if ppTypes then -- always true
          -- "default" binder group is the only one that expects binder names
          -- as a term, i.e. a single `Syntax.ident` or an application thereof
          let stxCurNames ←
            if curNames.size > 1 then -- never
              `($(curNames.get! 0) $(curNames.eraseIdx 0)*)
            else -- always ungrouped
              pure $ curNames.get! 0;
          `(funBinder| ($stxCurNames : $stxT))
        else -- never
          pure curNames.back  -- here `curNames.size == 1`
      let group ← match e.binderInfo, ppTypes with
        | BinderInfo.default,        _      => defaultCase ()
        | BinderInfo.implicit,       true   => `(funBinder| {$curNames* : $stxT})
        | BinderInfo.implicit,       false  => `(funBinder| {$curNames*})
        | BinderInfo.strictImplicit, true   => `(funBinder| ⦃$curNames* : $stxT⦄)
        | BinderInfo.strictImplicit, false  => `(funBinder| ⦃$curNames*⦄)
        | BinderInfo.instImplicit,   _     =>
          if usedDownstream then `(funBinder| [$curNames.back : $stxT])  -- here `curNames.size == 1`
          else  `(funBinder| [$stxT])
      let (binders, stxBody) :=
        match stxBody with
        | `(fun $binderGroups* => $stxBody) => (#[group] ++ binderGroups, stxBody)
        | _                                 => (#[group], stxBody)
      -- if ← getPPOption getPPUnicodeFun then
      `(fun $binders* ↦ $stxBody)
      -- else
      --   `(fun $binders* => $stxBody)

/--
Similar to `delabBinders`, but tracking whether `forallE` is dependent or not.

See issue #1571
-/
private partial def delabForallBinders (delabGroup : Array Syntax → Bool → Syntax → Delab) (curNames : Array Syntax := #[]) (curDep := false) : Delab := do
  let dep := !(← getExpr).isArrow
  if !curNames.isEmpty && dep != curDep then
    -- don't group
    delabGroup curNames curDep (← delabVerbose)
  else
    let curDep := dep
    -- if ← shouldGroupWithNext then
    --   -- group with nested binder => recurse immediately
    --   withBindingBodyUnusedName fun stxN => delabForallBinders delabGroup (curNames.push stxN) curDep
    -- else
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => return (← delab, stxN)
      delabGroup (curNames.push stxN) curDep stx

@[delab forallE]
def delabForall : Delab := do
  delabForallBinders fun curNames dependent stxBody => do
    let e ← getExpr
    let prop ← try isProp e catch _ => pure false
    let stxT ← withBindingDomain delab
    let group ← match e.binderInfo with
    | BinderInfo.implicit       => `(bracketedBinderF|{$curNames* : $stxT})
    | BinderInfo.strictImplicit => `(bracketedBinderF|⦃$curNames* : $stxT⦄)
    -- here `curNames.size == 1`
    | BinderInfo.instImplicit   => `(bracketedBinderF|[$curNames.back : $stxT])
    | _                         =>
      -- NOTE: non-dependent arrows are available only for the default binder info
      -- if dependent then
      --   if prop && !(← getPPOption getPPPiBinderTypes) then
      --     return ← `(∀ $curNames:ident*, $stxBody)
      --   else
          `(bracketedBinderF|($curNames* : $stxT))
      -- else
      --   return ← curNames.foldrM (fun _ stxBody => `($stxT → $stxBody)) stxBody
    if prop then
      match stxBody with
      | `(∀ $groups*, $stxBody) => `(∀ $group $groups*, $stxBody)
      | _                       => `(∀ $group, $stxBody)
    else
      `($group:bracketedBinder → $stxBody)

@[delab letE]
def delabLetE : Delab := do
  -- checkDepth
  let Expr.letE n t v b _ ← getExpr | unreachable!
  let n ← getUnusedName n b
  let stxV ← descend v 1 delabVerbose
  let stxB ← withLetDecl n t v fun fvar =>
    let b := b.instantiate1 fvar
    descend b 2 delabVerbose
  if ← getPPOption getPPLetVarTypes <||> getPPOption getPPAnalysisLetVarType then
    let stxT ← descend t 0 delab
    `(let $(mkIdent n) : $stxT := $stxV; $stxB)
  else `(let $(mkIdent n) := $stxV; $stxB)

@[delab app.dite]
def delabDIte : Delab := whenPPOption getPPNotation do
  -- Note: we keep this as a delaborator for now because it actually accesses the expression.
  guard $ (← getExpr).getAppNumArgs == 5
  let c ← withAppFn $ withAppFn $ withAppFn $ withAppArg delabVerbose
  let (t, h) ← withAppFn $ withAppArg $ delabBranch none
  let (e, _) ← withAppArg $ delabBranch h
  `(if $(mkIdent h):ident : $c then $t else $e)
where
  delabBranch (h? : Option Name) : DelabM (Syntax × Name) := do
    let e ← getExpr
    guard e.isLambda
    let h ← match h? with
      | some h => return (← withBindingBody h delabVerbose, h)
      | none   => withBindingBodyUnusedName fun h => do
        return (← delabVerbose, h.getId)

@[delab app.cond]
def delabCond : Delab := whenPPOption getPPNotation do
  -- checkDepth
  guard $ (← getExpr).getAppNumArgs == 4
  let c ← withAppFn $ withAppFn $ withAppArg delabVerbose
  let t ← withAppFn $ withAppArg delabVerbose
  let e ← withAppArg delabVerbose
  `(bif $c then $t else $e)

@[delab app.namedPattern]
def delabNamedPattern : Delab := do
  -- checkDepth
  -- Note: we keep this as a delaborator because it accesses the DelabM context
  guard (← read).inPattern
  guard $ (← getExpr).getAppNumArgs == 4
  let x ← withAppFn $ withAppFn $ withAppArg delab
  let p ← withAppFn $ withAppArg delab
  -- TODO: we should hide `h` if it has an inaccessible name and is not used in the rhs
  let h ← withAppArg delab
  guard x.raw.isIdent
  `($x:ident@$h:ident:$p:term)

-- Sigma and PSigma delaborators
def delabSigmaCore (sigma : Bool) : Delab := whenPPOption getPPNotation do
  checkDepth
  guard $ (← getExpr).getAppNumArgs == 2
  guard $ (← getExpr).appArg!.isLambda
  withAppArg do
    let α ← withBindingDomain delab
    let bodyExpr := (← getExpr).bindingBody!
    withBindingBodyUnusedName fun n => do
      let b ← delabVerbose
      if bodyExpr.hasLooseBVars then
        if sigma then `(($n:ident : $α) × $b) else `(($n:ident : $α) ×' $b)
      else
        if sigma then `((_ : $α) × $b) else `((_ : $α) ×' $b)

@[delab app.Sigma]
def delabSigma : Delab := delabSigmaCore (sigma := true)

@[delab app.PSigma]
def delabPSigma : Delab := delabSigmaCore (sigma := false)

partial def delabDoElems : DelabM (List Syntax) := do
  let e ← getExpr
  checkExprDepth e
  if e.isAppOfArity ``Bind.bind 6 then
    -- Bind.bind.{u, v} : {m : Type u → Type v} → [self : Bind m] → {α β : Type u} → m α → (α → m β) → m β
    let α := e.getAppArgs[2]!
    let ma ← withAppFn $ withAppArg delabVerbose
    withAppArg do
      match (← getExpr) with
      | Expr.lam _ _ body _ =>
        withBindingBodyUnusedName fun n => do
          if body.hasLooseBVars then
            prependAndRec `(doElem|let $n:term ← $ma:term)
          else if α.isConstOf ``Unit || α.isConstOf ``PUnit then
            prependAndRec `(doElem|$ma:term)
          else
            prependAndRec `(doElem|let _ ← $ma:term)
      | _ => failure
  else if e.isLet then
    let Expr.letE n t v b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxT ← descend t 0 delab
    let stxV ← descend v 1 delabVerbose
    withLetDecl n t v fun fvar =>
      let b := b.instantiate1 fvar
      descend b 2 $
        prependAndRec `(doElem|let $(mkIdent n) : $stxT := $stxV)
  else
    let stx ← delabVerbose
    return [← `(doElem|$stx:term)]
  where
    prependAndRec x : DelabM _ := List.cons <$> x <*> delabDoElems

-- @[delab app.Bind.bind]
-- def delabDo : Delab := whenPPOption getPPNotation do
--   guard <| (← getExpr).isAppOfArity ``Bind.bind 6
--   let elems ← delabDoElems
--   let items ← elems.toArray.mapM (`(doSeqItem|$(·):doElem))
--   `(do $items:doSeqItem*)

structure NameGroups where
  constNames : Array <| Name × Nat := #[]
  freeVarNames : Array Name := #[]
  domVarNames : Array Name := #[]
deriving Inhabited, Repr

def NameGroups.append (base: NameGroups) (n: Name)(d: Nat): NameGroups :=
  match n with
  | Name.str p "freeVar"  =>
    match p with
    | Name.str q "domVar"  => ⟨base.constNames, base.freeVarNames.push q, base.domVarNames⟩
    | _ => ⟨base.constNames, base.freeVarNames.push p, base.domVarNames⟩
  | Name.str q "domVar"  =>
      ⟨base.constNames, base.freeVarNames, base.domVarNames.push q⟩
  | _ => ⟨base.constNames.push (n, d), base.freeVarNames, base.domVarNames⟩

def groupedNames (nd : Array <| Name × Nat) : NameGroups :=
  nd.foldl (fun gp (n, d) => gp.append n d) {}

def lambdaStx?(stx : Syntax) : MetaM <| Option (Syntax × Array Syntax) := do
  match stx with
  | `(fun $args:funBinder* ↦ $body) =>
    return some (body, args)
  | `((fun $args:funBinder* ↦ $body)) =>
    return some (body, args)
  | _ => return none

def appStx?(stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `($f:term $arg:term) =>
    return some (f, arg)
  | _ => return none

#check Parser.mkIdent

def proofWithProp? (stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `(($stx =: $typeStx)) =>
    return some (stx, typeStx)
  | _ => return none

def getVar (stx: Syntax) : Option Name :=
match stx with
| `(funBinder|($n:ident)) => some n.getId
| `(funBinder|($n:ident : $_)) => some n.getId
| `(funBinder|{$n:ident : $_}) => some n.getId
| `(funBinder|⦃$n:ident : $_⦄) => some n.getId
| _ => none

def namedArgument? (stx : Syntax) : MetaM <| Option (Syntax × Syntax) := do
  match stx with
  | `(namedArgument|($n:ident := $stx)) =>
    return some (stx, n)
  | _ => return none

end LeanAide.Meta


import condensed.tensor
import for_mathlib.preserves_finite_limits

noncomputable theory

universes u
open_locale tensor_product

open category_theory category_theory.limits opposite

namespace AddCommGroup

@[reassoc]
lemma map_tensor_flip {A B C D : AddCommGroup} (f : A ⟶ B) (g : C ⟶ D) :
  map_tensor f g ≫ (tensor_flip _ _).hom = (tensor_flip _ _).hom ≫ map_tensor g f :=
by { apply AddCommGroup.tensor_ext, intros a c, refl }

end AddCommGroup

namespace Condensed

def tensor_tunit (A : AddCommGroup) (h : AddCommGroup.is_tensor_unit A) :
  tensor_functor.flip.obj A ≅ 𝟭 _ :=
begin
  refine _ ≪≫ (Condensed_ExtrSheaf_equiv Ab).counit_iso,
  refine nat_iso.of_components _ _,
  { intro M,
    refine (Condensed_ExtrSheaf_equiv Ab).functor.map_iso _,
    refine Sheaf.iso.mk _ _ _,
    refine nat_iso.of_components _ _,
    { intro S,
      refine (AddCommGroup.tensor_functor_iso_flip.app _).app _ ≪≫ _,
      refine AddCommGroup.tensor_unit_iso _ _ h, },
    { intros S T f,
      dsimp [ExtrSheaf.tensor, AddCommGroup.tensor_functor_iso_flip],
      simp only [category.assoc],
      erw AddCommGroup.tensor_unit_iso_naturality,
      rw ← AddCommGroup.map_tensor_flip_assoc, refl, } },
  { intros M N f,
    dsimp only [tensor_functor, map_tensor, functor.flip_obj_map,
      functor.comp_map, functor.map_iso_hom],
    simp only [← functor.map_comp], congr' 1,
    ext S : 3,
    dsimp only [Sheaf.category_theory.category_comp_val, ExtrSheaf.map_tensor_val, Sheaf.iso.mk_hom_val,
      nat_iso.of_components_hom_app, nat_trans.comp_app,
      ExtrSheafProd.map_tensor_val_app, iso.trans_hom],
    simp only [category.assoc],
    dsimp [AddCommGroup.tensor_functor_iso_flip],
    rw [AddCommGroup.map_tensor_flip_assoc], congr' 1,
    symmetry, apply AddCommGroup.tensor_unit_iso_naturality, }
end

def tensor_punit :
  tensor_functor.flip.obj (AddCommGroup.of (punit →₀ ℤ)) ≅ 𝟭 _ :=
tensor_tunit _ $
begin
  dsimp [AddCommGroup.is_tensor_unit],
  refine ⟨finsupp.single punit.star 1, _⟩,
  intro B, split,
  { intros f g h, ext ⟨⟩, exact h },
  { intros b, refine ⟨(finsupp.total _ _ _ _).to_add_monoid_hom, _⟩,
    { intro, exact b },
    { dsimp, simp only [finsupp.total_single, one_zsmul], } }
end

-- See comment around L20
instance preserves_mono_tensor_functor (A : Condensed.{u} Ab.{u+1})
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))]
  {X Y : Ab} (f : X ⟶ Y) [mono f] :
  mono ((tensor_functor.obj A).map f) :=
begin
  suffices : mono (ExtrSheaf.map_tensor ((Condensed_ExtrSheaf_equiv Ab).inverse.map (𝟙 A)) f),
  { dsimp only [tensor_functor, map_tensor], resetI, apply_instance },
  constructor, intros X φ ψ h, ext S : 3,
  apply_fun (λ η, η.val.app S) at h,
  dsimp [ExtrSheaf.map_tensor] at h,
  refine (@cancel_mono _ _ _ _ _ _ (id _) _ _).mp h,
  apply_with AddCommGroup.tensor_obj_map_preserves_mono {instances:=ff},
  apply_instance, apply_assumption
end
.

/-
We need one of the following two sorries.
If we prove the first, we can deduce the second using `exact_functor.lean`
But maybe it is easier to just prove `preserves_finite_limits_tensor_functor` second directly.
-/

-- lemma tensor_eval_iso_natural_right
--   (A : (Condensed.{u} Ab.{u+1})) {X Y : Ab} (f : X ⟶ Y) (S : ExtrDisc) :
--   AddCommGroup.map_tensor (𝟙 (A.val.obj (op S.val))) f ≫ (tensor_eval_iso A Y S).inv =
--   (tensor_eval_iso A X S).inv ≫ ((tensor_functor.obj A).map f).val.app (op S.val) :=
-- begin
--   rw [iso.comp_inv_eq],
--   dsimp only [tensor_eval_iso, tensor_functor, map_tensor,
--     functor.map_iso_hom, iso.app_hom, functor.map_iso_inv, iso.app_inv, iso.symm_hom, iso.symm_inv,
--     Sheaf_to_presheaf_map],
--   -- erw [equivalence.unit_app_inverse],
--   admit
-- end

-- lemma tensor_short_exact (A : (Condensed.{u} Ab.{u+1}))
--   [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))]
--   {X Y Z : Ab} (f : X ⟶ Y) (g : Y ⟶ Z) (hfg : short_exact f g) :
--   short_exact ((tensor_functor.obj A).map f) ((tensor_functor.obj A).map g) :=
-- begin
--   rw short_exact_iff_ExtrDisc, intro S,
--   let eX := tensor_eval_iso A X S,
--   let eY := tensor_eval_iso A Y S,
--   let eZ := tensor_eval_iso A Z S,
--   refine commsq.short_exact.of_iso eX.inv eY.inv eZ.inv _ _ _,
--   { refine (AddCommGroup.tensor_functor.obj _).map f, },
--   { refine (AddCommGroup.tensor_functor.obj _).map g, },
--   { apply AddCommGroup.tensor_short_exact, exact hfg },
--   { apply commsq.of_eq, apply tensor_eval_iso_natural_right },
--   { apply commsq.of_eq, apply tensor_eval_iso_natural_right },
-- end

-- See comment around L20
instance preserves_finite_limits_tensor_functor (A : Condensed.{u} Ab.{u+1})
  [∀ S : ExtrDisc.{u}, no_zero_smul_divisors ℤ (A.val.obj (op S.val))] :
  preserves_finite_limits (tensor_functor.obj A) :=
preserves_finite_limits_of_preserves_mono_preserves_finite_colimits _ $
λ X Y f hf, by { resetI, apply_instance }

end Condensed


import .commun
import .tokens

namespace tactic
setup_tactic_parser

meta def change_head_name (n : name) : tactic unit :=
do tgt ← target,
   match tgt with
   | (expr.pi old bi t b) := change_core (expr.pi n bi t b) none
   | _ := skip
   end

@[derive has_reflect]
meta inductive Montrons_args
| but : pexpr → Montrons_args    -- pour change
| temoin : pexpr → option pexpr → Montrons_args -- pour use
| ex_falso : Montrons_args       -- pour exfalso
| recur : name → pexpr → Montrons_args       -- pour les récurrences

open Montrons_args

meta def Montrons_parser : lean.parser Montrons_args :=
with_desc "que ... / Montrons que ... convient / Montrons une contradiction." $
(do t ← (tk "que")?,
    e ← texpr,
    if t.is_some then (do { t ← tk "convient",
         do { _ ← (tk ":"),
              But ← texpr,
              pure (temoin e $ some But) } <|> pure (temoin e none) } <|>
    pure (but e)) else pure (but e)) <|>
(Montrons_args.ex_falso <$ (tk "une" *> tk "contradiction")) <|>
(Montrons_args.recur <$> ((tk "par" *> tk "récurrence") *> ident) <*> (tk ":" *> texpr))

/-- Annonce ce qu'on va démontrer. -/
@[interactive]
meta def Montrons : parse Montrons_parser → tactic unit
| (but pe) := do e ← to_expr pe,
                do { change_core e none } <|>
                do { left, change_core e none} <|>
                do { right, change_core e none} <|>
                do { split, change_core e none} <|>
                do { interactive.push_neg (loc.ns [none]),
                     do { change_core e none } <|>
                     do { `[simp only [exists_prop]],
                          change_core e none } <|>
                     do { `[simp only [← exists_prop]],
                          change_core e none }
                     } <|>
                fail "Ce n'est pas ce qu'il faut démontrer"
| (temoin pe But) := do tactic.use [pe],
                    try `[simp only [exists_prop]],
                    t ← target,
                    match But with
                    | (some truc) := do etruc ← to_expr truc,
                                        change_core etruc none,
                                        skip
                    | none := skip
                    end,
                    match t with
                    | `(%%P ∧ %%Q) := split >> skip
                    | _ := skip
                    end
                    -- Les deux lignes suivantes sont supprimé en 2022 car trop imprévisible pour les étudiants
                    -- all_goals (try assumption),
                    --all_goals (try interactive.refl),

| ex_falso := tactic.interactive.exfalso
| (recur hyp pe) := focus1 (do
      verifie_nom hyp,
      e ← to_expr pe,
      match e with
      | (expr.pi n bi t b) := if t = `(ℕ) then do
              to_expr pe >>= tactic.assert hyp,
              `[refine nat.rec _ _],
              focus' [try `[dsimp only],
                      do { change_head_name n,
                           try `[simp_rw ← nat.add_one] },
                      do { e ← get_local hyp,
                           try (apply e) }],
              skip
          else fail "Cet énoncé doit commence par une quantification universelle sur un entier naturel."
      | _ := fail "Cet énoncé doit commence par une quantification universelle sur un entier naturel."
      end)

end tactic

example : 1 + 1 = 2 :=
begin
  Montrons que 2 = 2,
  refl
end

variables k : nat

example : ∃ k : ℕ, 4 = 2*k :=
begin
  Montrons que 2 convient,
  ring,
end

example : ∃ k : ℕ, 4 = 2*k :=
begin
  Montrons que 2 convient : 4 = 2*2,
  ring,
end

example : true ∧ true :=
begin
  Montrons true,
  all_goals {trivial}
end

example (P Q : Prop) (h : P) : P ∨ Q :=
begin
  Montrons que P,
  exact h
end

example (P Q : Prop) (h : Q) : P ∨ Q :=
begin
  Montrons que Q,
  exact h
end

example : 0 = 0 ∧ 1 = 1 :=
begin
  Montrons que 0 = 0,
  trivial,
  Montrons que 1 = 1,
  trivial
end
example : 0 = 0 ∧ 1 = 1 :=
begin
  Montrons que 0 = 0,
  trivial,
  Montrons que 1 = 1,
  trivial
end

example : true ↔ true :=
begin
  Montrons que true → true,
  all_goals { exact id },
end

example (h : false) : 2 = 1 :=
begin
  Montrons une contradiction,
  exact h
end

example (P : ℕ → Prop) (h₀ : P 0) (h : ∀ n, P n → P (n+1)) : P 3 :=
begin
  success_if_fail { Montrons par récurrence H : true },
  Montrons par récurrence H : ∀ n, P n,
  exact h₀,
  exact h,
end

example (P : ℕ → Prop) (h₀ : P 0) (h : ∀ n, P n → P (n+1)) : true :=
begin
  Montrons par récurrence H : ∀ k, P k,
  exacts [h₀, h, trivial],
end

example : true :=
begin
  Montrons par récurrence H : ∀ l, l < l + 1,
  dec_trivial,
  intro l,
  intros hl,
  linarith,
  trivial
end

example : true :=
begin
  success_if_fail { Montrons par récurrence H : true },
  success_if_fail { Montrons par récurrence H : ∀ n : ℤ, true },
  trivial
end