import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.types

namespace category_theory

open limits category_theory.limits.types

@[protect_proj] structure Function : Type 1 :=
( to_fun : Type → Type )
( R : Π {X₁ X₂}, (X₁ → X₂ → Prop) → to_fun X₁ → to_fun X₂ → Prop )

namespace Function

instance : has_coe_to_fun Function (λ _, Type → Type) :=
{ coe := Function.to_fun }

@[simp] lemma coe_mk (f h) : ⇑(Function.mk f h) = f := rfl

structure hom (F G : Function) : Type 1 :=
( to_fun : Π {X}, F X → G X )
( parametric : ∀ {X₁ X₂} {R : X₁ → X₂ → Prop} {x₁ : F X₁} {x₂ : F X₂},
    F.R R x₁ x₂ → G.R R (to_fun x₁) (to_fun x₂) )

instance : category_struct Function :=
{ hom := λ F G, hom F G,
  id := λ F, ⟨λ _, id, λ _ _ _ _ _, id⟩,
  comp := λ X Y Z n₁ n₂, ⟨λ X x, n₂.1 (n₁.1 x), λ X₁ X₂ R x₁ x₂ h, n₂.2 (n₁.2 h)⟩ }

instance (F G : Function) : has_coe_to_fun (F ⟶ G) (λ _, Π {X}, F X → G X) :=
{ coe := hom.to_fun }

lemma hom.ext_iff' {F G : Function} {f g : F ⟶ G} :
  f = g ↔ (@coe_fn _ _ _ f : Π {X : Type}, F X → G X) = coe_fn g :=
by cases f; cases g; simp [hom.mk.inj_eq]; refl

lemma hom.ext_iff {F G : Function} {f g : F ⟶ G} :
  f = g ↔ ∀ {X : Type} (x : F X), f x = g x :=
by simp [hom.ext_iff', function.funext_iff]

@[ext] lemma hom.ext {F G : Function} {f g : F ⟶ G}
  (h : ∀ (X : Type) (x : F X), f x = g x) : f = g :=
hom.ext_iff.2 h

@[simp] lemma coe_id (F : Function)  :
  (coe_fn (𝟙 F) : Π (X : Type), F X → F X) = (λ {X : Type}, @id (F X)) := rfl

@[simp] lemma coe_comp (F G H : Function) (f : F ⟶ G) (g : G ⟶ H) :
  coe_fn (f ≫ g) = (λ {X : Type} (x : F X), g (f x)) := rfl

instance : category Function := {}

def app (X : Type) : Function ⥤ Type :=
{ obj := λ F, F X,
  map := λ F G f a, f a }

instance : has_pullbacks Function :=
@has_pullbacks_of_has_limit_cospan _ _
(λ (F G H : Function) f g, ⟨⟨
{ cone := ⟨{ to_fun := λ X, pullback_obj ((app X).map f) ((app X).map g),
             R := λ X₁ X₂ R x y, F.R R x.1.1 y.1.1 ∧ G.R R x.1.2 y.1.2 },
    ⟨λ X, ⟨λ Y, option.cases_on X (λ x, f x.1.1)
        (λ X, limits.walking_pair.cases_on X (λ x, x.1.1) (λ x, x.1.2)),
      begin
        intros X₁ X₂ R x y,
        cases X,
        { exact λ h, f.2 h.1 },
        { cases X,
          exact and.left,
          exact and.right }
      end⟩, begin
        intros X Y f,
        cases f with f₁ f₂,
        cases X,
        { refl },
        { cases X; refl },
        { cases f₂,
          { refl },
          { ext Z x,
            rcases x with ⟨⟨x₁, x₂⟩, hx⟩,
            exact hx } }
      end⟩⟩,
  is_limit :=
    ⟨λ s,
      ⟨λ X x, ⟨⟨s.π.app limits.walking_span.left x,
                s.π.app limits.walking_span.right x⟩,
          (congr_fun (congr_fun (hom.ext_iff'.1 (s.2.2 limits.walking_cospan.hom.inl)) X) x).symm.trans
          (congr_fun (congr_fun (hom.ext_iff'.1 (s.2.2 limits.walking_cospan.hom.inr)) X) x)⟩,
      λ X₁ X₂ R x₁ x₂ h,  ⟨(s.2.1 walking_span.left).2 h,
          (s.2.1 walking_span.right).2 h⟩⟩,
    begin
      intros s j,
      cases j,
      { have := s.2.2 (limits.walking_cospan.hom.inl),
        dsimp at this,
        rw [category.id_comp] at this,
        refine eq.trans _ this.symm,
        refl },
      { cases j; ext; refl }
    end,
    begin
      intros s m hm,
      ext,
      { have := hm limits.walking_span.left,
        simp only [hom.ext_iff] at this,
        exact this _ },
      { have := hm limits.walking_span.right,
        simp only [hom.ext_iff] at this,
        exact this _ }
    end⟩ } ⟩⟩)

end Function

end category_theory


/-
Copyright (c) 2017 Simon Hudon All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.rat.cast
import Mathlib.data.rat.meta_defs
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

/-!
# `norm_num`

Evaluating arithmetic expressions including `*`, `+`, `-`, `^`, `≤`.
-/

namespace tactic

/-- Reflexivity conversion: given `e` returns `(e, ⊢ e = e)` -/
/-- Transitivity conversion: given two conversions (which take an
expression `e` and returns `(e', ⊢ e = e')`), produces another
conversion that combines them with transitivity, treating failures
as reflexivity conversions. -/
namespace instance_cache

/-- Faster version of `mk_app ``bit0 [e]`. -/
/-- Faster version of `mk_app ``bit1 [e]`. -/
end instance_cache

end tactic

namespace norm_num

theorem subst_into_add {α : Type u_1} [Add α] (l : α) (r : α) (tl : α) (tr : α) (t : α) (prl : l = tl) (prr : r = tr) (prt : tl + tr = t) : l + r = t :=
  eq.mpr (id (Eq._oldrec (Eq.refl (l + r = t)) prl))
    (eq.mpr (id (Eq._oldrec (Eq.refl (tl + r = t)) prr))
      (eq.mpr (id (Eq._oldrec (Eq.refl (tl + tr = t)) prt)) (Eq.refl t)))

theorem subst_into_mul {α : Type u_1} [Mul α] (l : α) (r : α) (tl : α) (tr : α) (t : α) (prl : l = tl) (prr : r = tr) (prt : tl * tr = t) : l * r = t :=
  eq.mpr (id (Eq._oldrec (Eq.refl (l * r = t)) prl))
    (eq.mpr (id (Eq._oldrec (Eq.refl (tl * r = t)) prr))
      (eq.mpr (id (Eq._oldrec (Eq.refl (tl * tr = t)) prt)) (Eq.refl t)))

theorem subst_into_neg {α : Type u_1} [Neg α] (a : α) (ta : α) (t : α) (pra : a = ta) (prt : -ta = t) : -a = t := sorry

/-- The result type of `match_numeral`, either `0`, `1`, or a top level
decomposition of `bit0 e` or `bit1 e`. The `other` case means it is not a numeral. -/
/-- Unfold the top level constructor of the numeral expression. -/
theorem zero_succ {α : Type u_1} [semiring α] : 0 + 1 = 1 :=
  zero_add 1

theorem one_succ {α : Type u_1} [semiring α] : 1 + 1 = bit0 1 :=
  rfl

theorem bit0_succ {α : Type u_1} [semiring α] (a : α) : bit0 a + 1 = bit1 a :=
  rfl

theorem bit1_succ {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : bit1 a + 1 = bit0 b := sorry

/-- Given `a`, `b` natural numerals, proves `⊢ a + 1 = b`, assuming that this is provable.
(It may prove garbage instead of failing if `a + 1 = b` is false.) -/
theorem zero_adc {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : 0 + a + 1 = b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (0 + a + 1 = b)) (zero_add a))) h

theorem adc_zero {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : a + 0 + 1 = b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a + 0 + 1 = b)) (add_zero a))) h

theorem one_add {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : 1 + a = b :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 + a = b)) (add_comm 1 a))) h

theorem add_bit0_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b = c) : bit0 a + bit0 b = bit0 c := sorry

theorem add_bit0_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b = c) : bit0 a + bit1 b = bit1 c := sorry

theorem add_bit1_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b = c) : bit1 a + bit0 b = bit1 c := sorry

theorem add_bit1_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b + 1 = c) : bit1 a + bit1 b = bit0 c := sorry

theorem adc_one_one {α : Type u_1} [semiring α] : 1 + 1 + 1 = bit1 1 :=
  rfl

theorem adc_bit0_one {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : bit0 a + 1 + 1 = bit0 b := sorry

theorem adc_one_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : 1 + bit0 a + 1 = bit0 b := sorry

theorem adc_bit1_one {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : bit1 a + 1 + 1 = bit1 b := sorry

theorem adc_one_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (h : a + 1 = b) : 1 + bit1 a + 1 = bit1 b := sorry

theorem adc_bit0_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b = c) : bit0 a + bit0 b + 1 = bit1 c := sorry

theorem adc_bit1_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b + 1 = c) : bit1 a + bit0 b + 1 = bit0 c := sorry

theorem adc_bit0_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b + 1 = c) : bit0 a + bit1 b + 1 = bit0 c := sorry

theorem adc_bit1_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a + b + 1 = c) : bit1 a + bit1 b + 1 = bit1 c := sorry

/-- Given `a`,`b`,`r` natural numerals, proves `⊢ a + b = r`. -/
/-- Given `a`,`b`,`r` natural numerals, proves `⊢ a + b + 1 = r`. -/
/-- Given `a`,`b` natural numerals, returns `(r, ⊢ a + b = r)`. -/
theorem bit0_mul {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a * b = c) : bit0 a * b = bit0 c := sorry

theorem mul_bit0' {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a * b = c) : a * bit0 b = bit0 c := sorry

theorem mul_bit0_bit0 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (h : a * b = c) : bit0 a * bit0 b = bit0 (bit0 c) :=
  bit0_mul a (bit0 b) (bit0 c) (mul_bit0' a b c h)

theorem mul_bit1_bit1 {α : Type u_1} [semiring α] (a : α) (b : α) (c : α) (d : α) (e : α) (hc : a * b = c) (hd : a + b = d) (he : bit0 c + d = e) : bit1 a * bit1 b = bit1 e := sorry

/-- Given `a`,`b` natural numerals, returns `(r, ⊢ a * b = r)`. -/
/-- Given `a` a positive natural numeral, returns `⊢ 0 < a`. -/
/-- Given `a` a rational numeral, returns `⊢ 0 < a`. -/
/-- `match_neg (- e) = some e`, otherwise `none` -/
/-- `match_sign (- e) = inl e`, `match_sign 0 = inr ff`, otherwise `inr tt` -/
theorem ne_zero_of_pos {α : Type u_1} [ordered_add_comm_group α] (a : α) : 0 < a → a ≠ 0 :=
  ne_of_gt

theorem ne_zero_neg {α : Type u_1} [add_group α] (a : α) : a ≠ 0 → -a ≠ 0 :=
  mt (iff.mp neg_eq_zero)

/-- Given `a` a rational numeral, returns `⊢ a ≠ 0`. -/
theorem clear_denom_div {α : Type u_1} [division_ring α] (a : α) (b : α) (b' : α) (c : α) (d : α) (h₀ : b ≠ 0) (h₁ : b * b' = d) (h₂ : a * b' = c) : a / b * d = c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a / b * d = c)) (Eq.symm h₁)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a / b * (b * b') = c)) (Eq.symm (mul_assoc (a / b) b b'))))
      (eq.mpr (id (Eq._oldrec (Eq.refl (a / b * b * b' = c)) (div_mul_cancel a h₀))) h₂))

/-- Given `a` nonnegative rational and `d` a natural number, returns `(b, ⊢ a * d = b)`.
(`d` should be a multiple of the denominator of `a`, so that `b` is a natural number.) -/
theorem nonneg_pos {α : Type u_1} [ordered_cancel_add_comm_monoid α] (a : α) : 0 < a → 0 ≤ a :=
  le_of_lt

theorem lt_one_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (h : 1 ≤ a) : 1 < bit0 a :=
  lt_of_lt_of_le one_lt_two (iff.mpr bit0_le_bit0 h)

theorem lt_one_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (h : 0 < a) : 1 < bit1 a :=
  iff.mpr one_lt_bit1 h

theorem lt_bit0_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) : a < b → bit0 a < bit0 b :=
  iff.mpr bit0_lt_bit0

theorem lt_bit0_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a ≤ b) : bit0 a < bit1 b :=
  lt_of_le_of_lt (iff.mpr bit0_le_bit0 h) (lt_add_one (bit0 b))

theorem lt_bit1_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a + 1 ≤ b) : bit1 a < bit0 b := sorry

theorem lt_bit1_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) : a < b → bit1 a < bit1 b :=
  iff.mpr bit1_lt_bit1

theorem le_one_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (h : 1 ≤ a) : 1 ≤ bit0 a :=
  le_of_lt (lt_one_bit0 a h)

-- deliberately strong hypothesis because bit1 0 is not a numeral

theorem le_one_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (h : 0 < a) : 1 ≤ bit1 a :=
  le_of_lt (lt_one_bit1 a h)

theorem le_bit0_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) : a ≤ b → bit0 a ≤ bit0 b :=
  iff.mpr bit0_le_bit0

theorem le_bit0_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a ≤ b) : bit0 a ≤ bit1 b :=
  le_of_lt (lt_bit0_bit1 a b h)

theorem le_bit1_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a + 1 ≤ b) : bit1 a ≤ bit0 b :=
  le_of_lt (lt_bit1_bit0 a b h)

theorem le_bit1_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) : a ≤ b → bit1 a ≤ bit1 b :=
  iff.mpr bit1_le_bit1

theorem sle_one_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) : 1 ≤ a → 1 + 1 ≤ bit0 a :=
  iff.mpr bit0_le_bit0

theorem sle_one_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) : 1 ≤ a → 1 + 1 ≤ bit1 a :=
  le_bit0_bit1 1 a

theorem sle_bit0_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) : a + 1 ≤ b → bit0 a + 1 ≤ bit0 b :=
  le_bit1_bit0 a b

theorem sle_bit0_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a ≤ b) : bit0 a + 1 ≤ bit1 b :=
  iff.mpr bit1_le_bit1 h

theorem sle_bit1_bit0 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a + 1 ≤ b) : bit1 a + 1 ≤ bit0 b :=
  Eq.symm (bit1_succ a (a + 1) rfl) ▸ iff.mpr bit0_le_bit0 h

theorem sle_bit1_bit1 {α : Type u_1} [linear_ordered_semiring α] (a : α) (b : α) (h : a + 1 ≤ b) : bit1 a + 1 ≤ bit1 b :=
  Eq.symm (bit1_succ a (a + 1) rfl) ▸ le_bit0_bit1 (a + 1) b h

/-- Given `a` a rational numeral, returns `⊢ 0 ≤ a`. -/
/-- Given `a` a rational numeral, returns `⊢ 1 ≤ a`. -/
/-- Given `a`,`b` natural numerals, proves `⊢ a ≤ b`. -/
/-- Given `a`,`b` natural numerals, proves `⊢ a + 1 ≤ b`. -/
/-- Given `a`,`b` natural numerals, proves `⊢ a < b`. -/
theorem clear_denom_lt {α : Type u_1} [linear_ordered_semiring α] (a : α) (a' : α) (b : α) (b' : α) (d : α) (h₀ : 0 < d) (ha : a * d = a') (hb : b * d = b') (h : a' < b') : a < b :=
  lt_of_mul_lt_mul_right
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * d < b * d)) ha)) (eq.mpr (id (Eq._oldrec (Eq.refl (a' < b * d)) hb)) h))
    (le_of_lt h₀)

/-- Given `a`,`b` nonnegative rational numerals, proves `⊢ a < b`. -/
theorem lt_neg_pos {α : Type u_1} [ordered_add_comm_group α] (a : α) (b : α) (ha : 0 < a) (hb : 0 < b) : -a < b :=
  lt_trans (neg_neg_of_pos ha) hb

/-- Given `a`,`b` rational numerals, proves `⊢ a < b`. -/
theorem clear_denom_le {α : Type u_1} [linear_ordered_semiring α] (a : α) (a' : α) (b : α) (b' : α) (d : α) (h₀ : 0 < d) (ha : a * d = a') (hb : b * d = b') (h : a' ≤ b') : a ≤ b :=
  le_of_mul_le_mul_right
    (eq.mpr (id (Eq._oldrec (Eq.refl (a * d ≤ b * d)) ha)) (eq.mpr (id (Eq._oldrec (Eq.refl (a' ≤ b * d)) hb)) h)) h₀

/-- Given `a`,`b` nonnegative rational numerals, proves `⊢ a ≤ b`. -/
theorem le_neg_pos {α : Type u_1} [ordered_add_comm_group α] (a : α) (b : α) (ha : 0 ≤ a) (hb : 0 ≤ b) : -a ≤ b :=
  le_trans (neg_nonpos_of_nonneg ha) hb

/-- Given `a`,`b` rational numerals, proves `⊢ a ≤ b`. -/
/-- Given `a`,`b` rational numerals, proves `⊢ a ≠ b`. This version tries to prove
`⊢ a < b` or `⊢ b < a`, and so is not appropriate for types without an order relation. -/
theorem nat_cast_zero {α : Type u_1} [semiring α] : ↑0 = 0 :=
  nat.cast_zero

theorem nat_cast_one {α : Type u_1} [semiring α] : ↑1 = 1 :=
  nat.cast_one

theorem nat_cast_bit0 {α : Type u_1} [semiring α] (a : ℕ) (a' : α) (h : ↑a = a') : ↑(bit0 a) = bit0 a' :=
  h ▸ nat.cast_bit0 a

theorem nat_cast_bit1 {α : Type u_1} [semiring α] (a : ℕ) (a' : α) (h : ↑a = a') : ↑(bit1 a) = bit1 a' :=
  h ▸ nat.cast_bit1 a

theorem int_cast_zero {α : Type u_1} [ring α] : ↑0 = 0 :=
  int.cast_zero

theorem int_cast_one {α : Type u_1} [ring α] : ↑1 = 1 :=
  int.cast_one

theorem int_cast_bit0 {α : Type u_1} [ring α] (a : ℤ) (a' : α) (h : ↑a = a') : ↑(bit0 a) = bit0 a' :=
  h ▸ int.cast_bit0 a

theorem int_cast_bit1 {α : Type u_1} [ring α] (a : ℤ) (a' : α) (h : ↑a = a') : ↑(bit1 a) = bit1 a' :=
  h ▸ int.cast_bit1 a

theorem rat_cast_bit0 {α : Type u_1} [division_ring α] [char_zero α] (a : ℚ) (a' : α) (h : ↑a = a') : ↑(bit0 a) = bit0 a' :=
  h ▸ rat.cast_bit0 a

theorem rat_cast_bit1 {α : Type u_1} [division_ring α] [char_zero α] (a : ℚ) (a' : α) (h : ↑a = a') : ↑(bit1 a) = bit1 a' :=
  h ▸ rat.cast_bit1 a

/-- Given `a' : α` a natural numeral, returns `(a : ℕ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
/-- Given `a' : α` a natural numeral, returns `(a : ℤ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
/-- Given `a' : α` a natural numeral, returns `(a : ℚ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
theorem rat_cast_div {α : Type u_1} [division_ring α] [char_zero α] (a : ℚ) (b : ℚ) (a' : α) (b' : α) (ha : ↑a = a') (hb : ↑b = b') : ↑(a / b) = a' / b' :=
  ha ▸ hb ▸ rat.cast_div a b

/-- Given `a' : α` a nonnegative rational numeral, returns `(a : ℚ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
theorem int_cast_neg {α : Type u_1} [ring α] (a : ℤ) (a' : α) (h : ↑a = a') : ↑(-a) = -a' :=
  h ▸ int.cast_neg a

theorem rat_cast_neg {α : Type u_1} [division_ring α] (a : ℚ) (a' : α) (h : ↑a = a') : ↑(-a) = -a' :=
  h ▸ rat.cast_neg a

/-- Given `a' : α` an integer numeral, returns `(a : ℤ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
/-- Given `a' : α` a rational numeral, returns `(a : ℚ, ⊢ ↑a = a')`.
(Note that the returned value is on the left of the equality.) -/
theorem nat_cast_ne {α : Type u_1} [semiring α] [char_zero α] (a : ℕ) (b : ℕ) (a' : α) (b' : α) (ha : ↑a = a') (hb : ↑b = b') (h : a ≠ b) : a' ≠ b' :=
  ha ▸ hb ▸ mt (iff.mp nat.cast_inj) h

theorem int_cast_ne {α : Type u_1} [ring α] [char_zero α] (a : ℤ) (b : ℤ) (a' : α) (b' : α) (ha : ↑a = a') (hb : ↑b = b') (h : a ≠ b) : a' ≠ b' :=
  ha ▸ hb ▸ mt (iff.mp int.cast_inj) h

theorem rat_cast_ne {α : Type u_1} [division_ring α] [char_zero α] (a : ℚ) (b : ℚ) (a' : α) (b' : α) (ha : ↑a = a') (hb : ↑b = b') (h : a ≠ b) : a' ≠ b' :=
  ha ▸ hb ▸ mt (iff.mp rat.cast_inj) h

/-- Given `a`,`b` rational numerals, proves `⊢ a ≠ b`. Currently it tries two methods:

  * Prove `⊢ a < b` or `⊢ b < a`, if the base type has an order
  * Embed `↑(a':ℚ) = a` and `↑(b':ℚ) = b`, and then prove `a' ≠ b'`.
    This requires that the base type be `char_zero`, and also that it be a `division_ring`
    so that the coercion from `ℚ` is well defined.

We may also add coercions to `ℤ` and `ℕ` as well in order to support `char_zero`
rings and semirings. -/
/-- Given `a` a rational numeral, returns `⊢ a ≠ 0`. -/
/-- Given `a` nonnegative rational and `d` a natural number, returns `(b, ⊢ a * d = b)`.
(`d` should be a multiple of the denominator of `a`, so that `b` is a natural number.) -/
theorem clear_denom_add {α : Type u_1} [division_ring α] (a : α) (a' : α) (b : α) (b' : α) (c : α) (c' : α) (d : α) (h₀ : d ≠ 0) (ha : a * d = a') (hb : b * d = b') (hc : c * d = c') (h : a' + b' = c') : a + b = c := sorry

/-- Given `a`,`b`,`c` nonnegative rational numerals, returns `⊢ a + b = c`. -/
theorem add_pos_neg_pos {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : c + b = a) : a + -b = c := sorry

theorem add_pos_neg_neg {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : c + a = b) : a + -b = -c := sorry

theorem add_neg_pos_pos {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : a + c = b) : -a + b = c := sorry

theorem add_neg_pos_neg {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : b + c = a) : -a + b = -c := sorry

theorem add_neg_neg {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : b + a = c) : -a + -b = -c := sorry

/-- Given `a`,`b`,`c` rational numerals, returns `⊢ a + b = c`. -/
/-- Given `a`,`b` rational numerals, returns `(c, ⊢ a + b = c)`. -/
theorem clear_denom_simple_nat {α : Type u_1} [division_ring α] (a : α) : 1 ≠ 0 ∧ a * 1 = a :=
  { left := one_ne_zero, right := mul_one a }

theorem clear_denom_simple_div {α : Type u_1} [division_ring α] (a : α) (b : α) (h : b ≠ 0) : b ≠ 0 ∧ a / b * b = a :=
  { left := h, right := div_mul_cancel a h }

/-- Given `a` a nonnegative rational numeral, returns `(b, c, ⊢ a * b = c)`
where `b` and `c` are natural numerals. (`b` will be the denominator of `a`.) -/
theorem clear_denom_mul {α : Type u_1} [field α] (a : α) (a' : α) (b : α) (b' : α) (c : α) (c' : α) (d₁ : α) (d₂ : α) (d : α) (ha : d₁ ≠ 0 ∧ a * d₁ = a') (hb : d₂ ≠ 0 ∧ b * d₂ = b') (hc : c * d = c') (hd : d₁ * d₂ = d) (h : a' * b' = c') : a * b = c := sorry

/-- Given `a`,`b` nonnegative rational numerals, returns `(c, ⊢ a * b = c)`. -/
theorem mul_neg_pos {α : Type u_1} [ring α] (a : α) (b : α) (c : α) (h : a * b = c) : -a * b = -c := sorry

theorem mul_pos_neg {α : Type u_1} [ring α] (a : α) (b : α) (c : α) (h : a * b = c) : a * -b = -c := sorry

theorem mul_neg_neg {α : Type u_1} [ring α] (a : α) (b : α) (c : α) (h : a * b = c) : -a * -b = c := sorry

/-- Given `a`,`b` rational numerals, returns `(c, ⊢ a * b = c)`. -/
theorem inv_neg {α : Type u_1} [division_ring α] (a : α) (b : α) (h : a⁻¹ = b) : -a⁻¹ = -b := sorry

theorem inv_one {α : Type u_1} [division_ring α] : 1⁻¹ = 1 :=
  inv_one

theorem inv_one_div {α : Type u_1} [division_ring α] (a : α) : 1 / a⁻¹ = a :=
  eq.mpr (id (Eq._oldrec (Eq.refl (1 / a⁻¹ = a)) (one_div a)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (a⁻¹⁻¹ = a)) (inv_inv' a))) (Eq.refl a))

theorem inv_div_one {α : Type u_1} [division_ring α] (a : α) : a⁻¹ = 1 / a :=
  inv_eq_one_div a

theorem inv_div {α : Type u_1} [division_ring α] (a : α) (b : α) : a / b⁻¹ = b / a := sorry

/-- Given `a` a rational numeral, returns `(b, ⊢ a⁻¹ = b)`. -/
theorem div_eq {α : Type u_1} [division_ring α] (a : α) (b : α) (b' : α) (c : α) (hb : b⁻¹ = b') (h : a * b' = c) : a / b = c :=
  eq.mp (Eq._oldrec (Eq.refl (a * (b⁻¹) = c)) (Eq.symm (div_eq_mul_inv a b)))
    (eq.mp (Eq._oldrec (Eq.refl (a * b' = c)) (Eq.symm hb)) h)

/-- Given `a`,`b` rational numerals, returns `(c, ⊢ a / b = c)`. -/
/-- Given `a` a rational numeral, returns `(b, ⊢ -a = b)`. -/
theorem sub_pos {α : Type u_1} [add_group α] (a : α) (b : α) (b' : α) (c : α) (hb : -b = b') (h : a + b' = c) : a - b = c :=
  eq.mp (Eq._oldrec (Eq.refl (a + -b = c)) (Eq.symm (sub_eq_add_neg a b)))
    (eq.mp (Eq._oldrec (Eq.refl (a + b' = c)) (Eq.symm hb)) h)

theorem sub_neg {α : Type u_1} [add_group α] (a : α) (b : α) (c : α) (h : a + b = c) : a - -b = c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (a - -b = c)) (sub_neg_eq_add a b))) h

/-- Given `a`,`b` rational numerals, returns `(c, ⊢ a - b = c)`. -/
theorem sub_nat_pos (a : ℕ) (b : ℕ) (c : ℕ) (h : b + c = a) : a - b = c :=
  h ▸ nat.add_sub_cancel_left b c

theorem sub_nat_neg (a : ℕ) (b : ℕ) (c : ℕ) (h : a + c = b) : a - b = 0 :=
  nat.sub_eq_zero_of_le (h ▸ nat.le_add_right a c)

/-- Given `a : nat`,`b : nat` natural numerals, returns `(c, ⊢ a - b = c)`. -/
/-- Evaluates the basic field operations `+`,`neg`,`-`,`*`,`inv`,`/` on numerals.
Also handles nat subtraction. Does not do recursive simplification; that is,
`1 + 1 + 1` will not simplify but `2 + 1` will. This is handled by the top level
`simp` call in `norm_num.derive`. -/
theorem pow_bit0 {α : Type u} [monoid α] (a : α) (c' : α) (c : α) (b : ℕ) (h : a ^ b = c') (h₂ : c' * c' = c) : a ^ bit0 b = c := sorry

theorem pow_bit1 {α : Type u} [monoid α] (a : α) (c₁ : α) (c₂ : α) (c : α) (b : ℕ) (h : a ^ b = c₁) (h₂ : c₁ * c₁ = c₂) (h₃ : c₂ * a = c) : a ^ bit1 b = c := sorry

/-- Given `a` a rational numeral and `b : nat`, returns `(c, ⊢ a ^ b = c)`. -/
/-- Evaluates expressions of the form `a ^ b`, `monoid.pow a b` or `nat.pow a b`. -/
/-- Given `⊢ p`, returns `(true, ⊢ p = true)`. -/
/-- Given `⊢ ¬ p`, returns `(false, ⊢ p = false)`. -/
theorem not_refl_false_intro {α : Sort u_1} (a : α) : a ≠ a = False :=
  eq_false_intro (not_not_intro rfl)

/-- Evaluates the inequality operations `=`,`<`,`>`,`≤`,`≥`,`≠` on numerals. -/
theorem nat_succ_eq (a : ℕ) (b : ℕ) (c : ℕ) (h₁ : a = b) (h₂ : b + 1 = c) : Nat.succ a = c :=
  eq.mpr (id (Eq._oldrec (Eq.refl (Nat.succ a = c)) h₁)) h₂

/-- Evaluates the expression `nat.succ ... (nat.succ n)` where `n` is a natural numeral.
(We could also just handle `nat.succ n` here and rely on `simp` to work bottom up, but we figure
that towers of successors coming from e.g. `induction` are a common case.) -/
theorem nat_div (a : ℕ) (b : ℕ) (q : ℕ) (r : ℕ) (m : ℕ) (hm : q * b = m) (h : r + m = a) (h₂ : r < b) : a / b = q := sorry

theorem int_div (a : ℤ) (b : ℤ) (q : ℤ) (r : ℤ) (m : ℤ) (hm : q * b = m) (h : r + m = a) (h₁ : 0 ≤ r) (h₂ : r < b) : a / b = q := sorry

theorem nat_mod (a : ℕ) (b : ℕ) (q : ℕ) (r : ℕ) (m : ℕ) (hm : q * b = m) (h : r + m = a) (h₂ : r < b) : a % b = r := sorry

theorem int_mod (a : ℤ) (b : ℤ) (q : ℤ) (r : ℤ) (m : ℤ) (hm : q * b = m) (h : r + m = a) (h₁ : 0 ≤ r) (h₂ : r < b) : a % b = r := sorry

theorem int_div_neg (a : ℤ) (b : ℤ) (c' : ℤ) (c : ℤ) (h : a / b = c') (h₂ : -c' = c) : a / -b = c :=
  h₂ ▸ h ▸ int.div_neg a b

theorem int_mod_neg (a : ℤ) (b : ℤ) (c : ℤ) (h : a % b = c) : a % -b = c :=
  Eq.trans (int.mod_neg a b) h

/-- Given `a`,`b` numerals in `nat` or `int`,
  * `prove_div_mod ic a b ff` returns `(c, ⊢ a / b = c)`
  * `prove_div_mod ic a b tt` returns `(c, ⊢ a % b = c)`
-/
theorem dvd_eq_nat (a : ℕ) (b : ℕ) (c : ℕ) (p : Prop) (h₁ : b % a = c) (h₂ : c = 0 = p) : a ∣ b = p := sorry

theorem dvd_eq_int (a : ℤ) (b : ℤ) (c : ℤ) (p : Prop) (h₁ : b % a = c) (h₂ : c = 0 = p) : a ∣ b = p := sorry

/-- Evaluates some extra numeric operations on `nat` and `int`, specifically
`nat.succ`, `/` and `%`, and `∣` (divisibility). -/
/-- This version of `derive` does not fail when the input is already a numeral -/
/-- An attribute for adding additional extensions to `norm_num`. To use this attribute, put
`@[norm_num]` on a tactic of type `expr → tactic (expr × expr)`; the tactic will be called on
subterms by `norm_num`, and it is responsible for identifying that the expression is a numerical
function applied to numerals, for example `nat.fib 17`, and should return the reduced numerical
expression (which must be in `norm_num`-normal form: a natural or rational numeral, i.e. `37`,
`12 / 7` or `-(2 / 3)`, although this can be an expression in any type), and the proof that the
original expression is equal to the rewritten expression.

Failure is used to indicate that this tactic does not apply to the term. For performance reasons,
it is best to detect non-applicability as soon as possible so that the next tactic can have a go,
so generally it will start with a pattern match and then checking that the arguments to the term
are numerals or of the appropriate form, followed by proof construction, which should not fail.

Propositions are treated like any other term. The normal form for propositions is `true` or
`false`, so it should produce a proof of the form `p = true` or `p = false`. `eq_true_intro` can be
used to help here.
-/
/-- Look up the `norm_num` extensions in the cache and return a tactic extending `derive.step` with
additional reduction procedures. -/
/-- Simplify an expression bottom-up using `step` to simplify the subexpressions. -/
/-- Simplify an expression bottom-up using the default `norm_num` set to simplify the
subexpressions. -/
end norm_num

/-- Basic version of `norm_num` that does not call `simp`. It uses the provided `step` tactic
to simplify the expression; use `get_step` to get the default `norm_num` set and `derive.step` for
the basic builtin set of simplifications. -/
/-- Normalize numerical expressions. It uses the provided `step` tactic to simplify the expression;
use `get_step` to get the default `norm_num` set and `derive.step` for the basic builtin set of
simplifications. -/
namespace tactic.interactive

/-- Basic version of `norm_num` that does not call `simp`. -/
/-- Normalize numerical expressions. Supports the operations
`+` `-` `*` `/` `^` and `%` over numerical types such as
`ℕ`, `ℤ`, `ℚ`, `ℝ`, `ℂ` and some general algebraic types,
and can prove goals of the form `A = B`, `A ≠ B`, `A < B` and `A ≤ B`,
where `A` and `B` are numerical expressions.
It also has a relatively simple primality prover. -/
/-- Normalizes a numerical expression and tries to close the goal with the result. -/
/--
Normalises numerical expressions. It supports the operations `+` `-` `*` `/` `^` and `%` over


import classes.context_free.basics.inclusion
import classes.unrestricted.closure_properties.concatenation
import utilities.written_by_others.trim_assoc
import utilities.written_by_others.print_sorries

variables {T : Type}

private def wrap_CF_rule₁ {N₁ : Type} (N₂ : Type) (r : (N₁ × list (symbol T N₁))) :
  ((nnn T N₁ N₂) × list (nst T N₁ N₂)) :=
((sum.inl (some (sum.inl r.fst))), (list.map (wrap_symbol₁ N₂) r.snd))

private def wrap_CF_rule₂ {N₂ : Type} (N₁ : Type) (r : (N₂ × list (symbol T N₂))) :
  ((nnn T N₁ N₂) × list (nst T N₁ N₂)) :=
((sum.inl (some (sum.inr r.fst))), (list.map (wrap_symbol₂ N₁) r.snd))

private def CF_rules_for_terminals₁ (N₂ : Type) (g : CF_grammar T) :
  list ((nnn T g.nt N₂) × list (nst T g.nt N₂)) :=
list.map (λ t, ((sum.inr (sum.inl t)), [symbol.terminal t])) (all_used_terminals (grammar_of_cfg g))

private def CF_rules_for_terminals₂ (N₁ : Type) (g : CF_grammar T) :
  list ((nnn T N₁ g.nt) × list (nst T N₁ g.nt)) :=
list.map (λ t, ((sum.inr (sum.inr t)), [symbol.terminal t])) (all_used_terminals (grammar_of_cfg g))

private def big_CF_grammar (g₁ g₂ : CF_grammar T) : CF_grammar T :=
CF_grammar.mk
  (nnn T g₁.nt g₂.nt)
  (sum.inl none)
  (((sum.inl none), [
    symbol.nonterminal (sum.inl (some (sum.inl g₁.initial))),
    symbol.nonterminal (sum.inl (some (sum.inr g₂.initial)))]
  ) :: (
    (list.map (wrap_CF_rule₁ g₂.nt) g₁.rules ++ list.map (wrap_CF_rule₂ g₁.nt) g₂.rules) ++
    (CF_rules_for_terminals₁ g₂.nt g₁ ++ CF_rules_for_terminals₂ g₁.nt g₂)
  ))

private lemma big_CF_grammar_same_language (g₁ g₂ : CF_grammar T) :
  CF_language (big_CF_grammar g₁ g₂) = grammar_language (big_grammar (grammar_of_cfg g₁) (grammar_of_cfg g₂)) :=
begin
  rw CF_language_eq_grammar_language,
  congr,
  unfold big_CF_grammar,
  unfold grammar_of_cfg,
  unfold big_grammar,
  dsimp only [list.map],
  congr,
  repeat {
    rw list.map_append,
  },
  trim,
  {
    apply congr_arg2,
    {
      unfold rules_for_terminals₁,
      unfold CF_rules_for_terminals₁,
      finish,
    },
    {
      unfold rules_for_terminals₂,
      unfold CF_rules_for_terminals₂,
      finish,
    },
  },
end

/-- The class of context-free languages is closed under concatenation.
    This theorem is proved by translation from general grammars.
    Compare to `classes.context_free.closure_properties.concatenation.lean` which uses
    a simpler and more effective construction (based on context-gree grammars only). -/
private theorem bonus_CF_of_CF_c_CF (L₁ : language T) (L₂ : language T) :
  is_CF L₁  ∧  is_CF L₂   →   is_CF (L₁ * L₂)   :=
begin
  rintro ⟨⟨g₁, eq_L₁⟩, ⟨g₂, eq_L₂⟩⟩,
  rw CF_language_eq_grammar_language g₁ at eq_L₁,
  rw CF_language_eq_grammar_language g₂ at eq_L₂,

  use big_CF_grammar g₁ g₂,
  rw big_CF_grammar_same_language,

  apply set.eq_of_subset_of_subset,
  {
    intros w hyp,
    rw ←eq_L₁,
    rw ←eq_L₂,
    exact in_concatenated_of_in_big hyp,
  },
  {
    intros w hyp,
    rw ←eq_L₁ at hyp,
    rw ←eq_L₂ at hyp,
    exact in_big_of_in_concatenated hyp,
  },
end

#check            bonus_CF_of_CF_c_CF
#print_sorries_in bonus_CF_of_CF_c_CF


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

Nonnegative real numbers.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.infinite_sum
import Mathlib.topology.algebra.group_with_zero
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace nnreal

protected instance topological_space : topological_space nnreal := infer_instance

protected instance topological_semiring : topological_semiring nnreal := topological_semiring.mk

protected instance topological_space.second_countable_topology :
    topological_space.second_countable_topology nnreal :=
  topological_space.subtype.second_countable_topology ℝ fun (r : ℝ) => real.le 0 r

protected instance order_topology : order_topology nnreal := Mathlib.order_topology_of_ord_connected

theorem continuous_of_real : continuous nnreal.of_real :=
  continuous_subtype_mk (fun (r : ℝ) => of_real._proof_1 r)
    (continuous.max continuous_id continuous_const)

theorem continuous_coe : continuous coe := continuous_subtype_val

@[simp] theorem tendsto_coe {α : Type u_1} {f : filter α} {m : α → nnreal} {x : nnreal} :
    filter.tendsto (fun (a : α) => ↑(m a)) f (nhds ↑x) ↔ filter.tendsto m f (nhds x) :=
  iff.symm tendsto_subtype_rng

theorem tendsto_coe' {α : Type u_1} {f : filter α} [filter.ne_bot f] {m : α → nnreal} {x : ℝ} :
    filter.tendsto (fun (a : α) => ↑(m a)) f (nhds x) ↔
        ∃ (hx : 0 ≤ x), filter.tendsto m f (nhds { val := x, property := hx }) :=
  sorry

@[simp] theorem map_coe_at_top : filter.map coe filter.at_top = filter.at_top :=
  filter.map_coe_Ici_at_top 0

theorem comap_coe_at_top : filter.comap coe filter.at_top = filter.at_top :=
  Eq.symm (filter.at_top_Ici_eq 0)

@[simp] theorem tendsto_coe_at_top {α : Type u_1} {f : filter α} {m : α → nnreal} :
    filter.tendsto (fun (a : α) => ↑(m a)) f filter.at_top ↔ filter.tendsto m f filter.at_top :=
  iff.symm filter.tendsto_Ici_at_top

theorem tendsto_of_real {α : Type u_1} {f : filter α} {m : α → ℝ} {x : ℝ}
    (h : filter.tendsto m f (nhds x)) :
    filter.tendsto (fun (a : α) => nnreal.of_real (m a)) f (nhds (nnreal.of_real x)) :=
  filter.tendsto.comp (continuous.tendsto continuous_of_real x) h

protected instance has_continuous_sub : has_continuous_sub nnreal :=
  has_continuous_sub.mk
    (continuous_subtype_mk
      (fun (p : nnreal × nnreal) => of_real._proof_1 (↑(prod.fst p) - ↑(prod.snd p)))
      (continuous.max
        (continuous.sub (continuous.comp continuous_coe continuous_fst)
          (continuous.comp continuous_coe continuous_snd))
        continuous_const))

protected instance has_continuous_inv' : has_continuous_inv' nnreal := has_continuous_inv'.mk sorry

theorem has_sum_coe {α : Type u_1} {f : α → nnreal} {r : nnreal} :
    has_sum (fun (a : α) => ↑(f a)) ↑r ↔ has_sum f r :=
  sorry

theorem has_sum_of_real_of_nonneg {α : Type u_1} {f : α → ℝ} (hf_nonneg : ∀ (n : α), 0 ≤ f n)
    (hf : summable f) :
    has_sum (fun (n : α) => nnreal.of_real (f n)) (nnreal.of_real (tsum fun (n : α) => f n)) :=
  sorry

theorem summable_coe {α : Type u_1} {f : α → nnreal} :
    (summable fun (a : α) => ↑(f a)) ↔ summable f :=
  sorry

theorem coe_tsum {α : Type u_1} {f : α → nnreal} :
    ↑(tsum fun (a : α) => f a) = tsum fun (a : α) => ↑(f a) :=
  sorry

theorem tsum_mul_left {α : Type u_1} (a : nnreal) (f : α → nnreal) :
    (tsum fun (x : α) => a * f x) = a * tsum fun (x : α) => f x :=
  sorry

theorem tsum_mul_right {α : Type u_1} (f : α → nnreal) (a : nnreal) :
    (tsum fun (x : α) => f x * a) = (tsum fun (x : α) => f x) * a :=
  sorry

theorem summable_comp_injective {α : Type u_1} {β : Type u_2} {f : α → nnreal} (hf : summable f)
    {i : β → α} (hi : function.injective i) : summable (f ∘ i) :=
  iff.mp summable_coe
    ((fun (this : summable ((coe ∘ f) ∘ i)) => this)
      (summable.comp_injective (iff.mpr summable_coe hf) hi))

theorem summable_nat_add (f : ℕ → nnreal) (hf : summable f) (k : ℕ) :
    summable fun (i : ℕ) => f (i + k) :=
  summable_comp_injective hf (add_left_injective k)

theorem summable_nat_add_iff {f : ℕ → nnreal} (k : ℕ) :
    (summable fun (i : ℕ) => f (i + k)) ↔ summable f :=
  sorry

theorem sum_add_tsum_nat_add {f : ℕ → nnreal} (k : ℕ) (hf : summable f) :
    (tsum fun (i : ℕ) => f i) =
        (finset.sum (finset.range k) fun (i : ℕ) => f i) + tsum fun (i : ℕ) => f (i + k) :=
  sorry

theorem infi_real_pos_eq_infi_nnreal_pos {α : Type u_1} [complete_lattice α] {f : ℝ → α} :
    (infi fun (n : ℝ) => infi fun (h : 0 < n) => f n) =
        infi fun (n : nnreal) => infi fun (h : 0 < n) => f ↑n :=
  sorry

end Mathlib


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

! This file was ported from Lean 3 source module algebra.field.ulift
! leanprover-community/mathlib commit 932872382355f00112641d305ba0619305dc8642
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Field.Basic
import Mathbin.Algebra.Ring.Ulift

/-!
# Field instances for `ulift`

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

This file defines instances for field, semifield and related structures on `ulift` types.

(Recall `ulift α` is just a "copy" of a type `α` in a higher universe.)
-/

universe u v

variable {α : Type u} {x y : ULift.{v} α}

namespace ULift

instance [HasRatCast α] : HasRatCast (ULift α) :=
  ⟨fun a => up a⟩

/- warning: ulift.up_rat_cast -> ULift.up_ratCast is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HasRatCast.{u1} α] (q : Rat), Eq.{succ (max u1 u2)} (ULift.{u2, u1} α) (ULift.up.{u2, u1} α ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Rat α (HasLiftT.mk.{1, succ u1} Rat α (CoeTCₓ.coe.{1, succ u1} Rat α (Rat.castCoe.{u1} α _inst_1))) q)) ((fun (a : Type) (b : Type.{max u1 u2}) [self : HasLiftT.{1, succ (max u1 u2)} a b] => self.0) Rat (ULift.{u2, u1} α) (HasLiftT.mk.{1, succ (max u1 u2)} Rat (ULift.{u2, u1} α) (CoeTCₓ.coe.{1, succ (max u1 u2)} Rat (ULift.{u2, u1} α) (Rat.castCoe.{max u1 u2} (ULift.{u2, u1} α) (ULift.hasRatCast.{u1, u2} α _inst_1)))) q)
but is expected to have type
  forall {α : Type.{u2}} [_inst_1 : RatCast.{u2} α] (q : Rat), Eq.{max (succ u2) (succ u1)} (ULift.{u1, u2} α) (ULift.up.{u1, u2} α (Rat.cast.{u2} α _inst_1 q)) (Rat.cast.{max u2 u1} (ULift.{u1, u2} α) (ULift.instRatCastULift.{u2, u1} α _inst_1) q)
Case conversion may be inaccurate. Consider using '#align ulift.up_rat_cast ULift.up_ratCastₓ'. -/
@[simp, norm_cast]
theorem up_ratCast [HasRatCast α] (q : ℚ) : up (q : α) = q :=
  rfl
#align ulift.up_rat_cast ULift.up_ratCast

/- warning: ulift.down_rat_cast -> ULift.down_ratCast is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : HasRatCast.{u1} α] (q : Rat), Eq.{succ u1} α (ULift.down.{u2, u1} α ((fun (a : Type) (b : Type.{max u1 u2}) [self : HasLiftT.{1, succ (max u1 u2)} a b] => self.0) Rat (ULift.{u2, u1} α) (HasLiftT.mk.{1, succ (max u1 u2)} Rat (ULift.{u2, u1} α) (CoeTCₓ.coe.{1, succ (max u1 u2)} Rat (ULift.{u2, u1} α) (Rat.castCoe.{max u1 u2} (ULift.{u2, u1} α) (ULift.hasRatCast.{u1, u2} α _inst_1)))) q)) ((fun (a : Type) (b : Type.{u1}) [self : HasLiftT.{1, succ u1} a b] => self.0) Rat α (HasLiftT.mk.{1, succ u1} Rat α (CoeTCₓ.coe.{1, succ u1} Rat α (Rat.castCoe.{u1} α _inst_1))) q)
but is expected to have type
  forall {α : Type.{u2}} [_inst_1 : RatCast.{u2} α] (q : Rat), Eq.{succ u2} α (ULift.down.{u1, u2} α (Rat.cast.{max u2 u1} (ULift.{u1, u2} α) (ULift.instRatCastULift.{u2, u1} α _inst_1) q)) (Rat.cast.{u2} α _inst_1 q)
Case conversion may be inaccurate. Consider using '#align ulift.down_rat_cast ULift.down_ratCastₓ'. -/
@[simp, norm_cast]
theorem down_ratCast [HasRatCast α] (q : ℚ) : down (q : ULift α) = q :=
  rfl
#align ulift.down_rat_cast ULift.down_ratCast

#print ULift.divisionSemiring /-
instance divisionSemiring [DivisionSemiring α] : DivisionSemiring (ULift α) := by
  refine' down_injective.division_semiring down _ _ _ _ _ _ _ _ _ _ <;> intros <;> rfl
#align ulift.division_semiring ULift.divisionSemiring
-/

#print ULift.semifield /-
instance semifield [Semifield α] : Semifield (ULift α) :=
  { ULift.divisionSemiring, ULift.commGroupWithZero with }
#align ulift.semifield ULift.semifield
-/

#print ULift.divisionRing /-
instance divisionRing [DivisionRing α] : DivisionRing (ULift α) :=
  { ULift.divisionSemiring, ULift.addGroup with }
#align ulift.division_ring ULift.divisionRing
-/

#print ULift.field /-
instance field [Field α] : Field (ULift α) :=
  { ULift.semifield, ULift.divisionRing with }
#align ulift.field ULift.field
-/

end ULift


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.sites.sheaf_of_types
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# The canonical topology on a category

We define the finest (largest) Grothendieck topology for which a given presheaf `P` is a sheaf.
This is well defined since if `P` is a sheaf for a topology `J`, then it is a sheaf for any
coarser (smaller) topology. Nonetheless we define the topology explicitly by specifying its sieves:
A sieve `S` on `X` is covering for `finest_topology_single P` iff
  for any `f : Y ⟶ X`, `P` satisfies the sheaf axiom for `S.pullback f`.
Showing that this is a genuine Grothendieck topology (namely that it satisfies the transitivity
axiom) forms the bulk of this file.

This generalises to a set of presheaves, giving the topology `finest_topology Ps` which is the
finest topology for which every presheaf in `Ps` is a sheaf.
Using `Ps` as the set of representable presheaves defines the `canonical_topology`: the finest
topology for which every representable is a sheaf.

A Grothendieck topology is called `subcanonical` if it is smaller than the canonical topology,
equivalently it is subcanonical iff every representable presheaf is a sheaf.

## References
* https://ncatlab.org/nlab/show/canonical+topology
* https://ncatlab.org/nlab/show/subcanonical+coverage
* https://stacks.math.columbia.edu/tag/00Z9
* https://math.stackexchange.com/a/358709/
-/

namespace category_theory

namespace sheaf

/--
To show `P` is a sheaf for the binding of `U` with `B`, it suffices to show that `P` is a sheaf for
`U`, that `P` is a sheaf for each sieve in `B`, and that it is separated for any pullback of any
sieve in `B`.

This is mostly an auxiliary lemma to show `is_sheaf_for_trans`.
Adapted from [Elephant], Lemma C2.1.7(i) with suggestions as mentioned in
https://math.stackexchange.com/a/358709/
-/
theorem is_sheaf_for_bind {C : Type u} [category C] {X : C} (P : Cᵒᵖ ⥤ Type v) (U : sieve X)
    (B : {Y : C} → {f : Y ⟶ X} → coe_fn U Y f → sieve Y) (hU : presieve.is_sheaf_for P ⇑U)
    (hB : ∀ {Y : C} {f : Y ⟶ X} (hf : coe_fn U Y f), presieve.is_sheaf_for P ⇑(B hf))
    (hB' :
      ∀ {Y : C} {f : Y ⟶ X} (h : coe_fn U Y f) {Z : C} (g : Z ⟶ Y),
        presieve.is_separated_for P ⇑(sieve.pullback g (B h))) :
    presieve.is_sheaf_for P ⇑(sieve.bind (⇑U) B) :=
  sorry

/--
Given two sieves `R` and `S`, to show that `P` is a sheaf for `S`, we can show:
* `P` is a sheaf for `R`
* `P` is a sheaf for the pullback of `S` along any arrow in `R`
* `P` is separated for the pullback of `R` along any arrow in `S`.

This is mostly an auxiliary lemma to construct `finest_topology`.
Adapted from [Elephant], Lemma C2.1.7(ii) with suggestions as mentioned in
https://math.stackexchange.com/a/358709
-/
theorem is_sheaf_for_trans {C : Type u} [category C] {X : C} (P : Cᵒᵖ ⥤ Type v) (R : sieve X)
    (S : sieve X) (hR : presieve.is_sheaf_for P ⇑R)
    (hR' : ∀ {Y : C} {f : Y ⟶ X}, coe_fn S Y f → presieve.is_separated_for P ⇑(sieve.pullback f R))
    (hS : ∀ {Y : C} {f : Y ⟶ X}, coe_fn R Y f → presieve.is_sheaf_for P ⇑(sieve.pullback f S)) :
    presieve.is_sheaf_for P ⇑S :=
  sorry

/--
Construct the finest (largest) Grothendieck topology for which the given presheaf is a sheaf.

This is a special case of https://stacks.math.columbia.edu/tag/00Z9, but following a different
proof (see the comments there).
-/
def finest_topology_single {C : Type u} [category C] (P : Cᵒᵖ ⥤ Type v) : grothendieck_topology C :=
  grothendieck_topology.mk
    (fun (X : C) (S : sieve X) =>
      ∀ (Y : C) (f : Y ⟶ X), presieve.is_sheaf_for P ⇑(sieve.pullback f S))
    sorry sorry sorry

/--
Construct the finest (largest) Grothendieck topology for which all the given presheaves are sheaves.

This is equal to the construction of https://stacks.math.columbia.edu/tag/00Z9.
-/
def finest_topology {C : Type u} [category C] (Ps : set (Cᵒᵖ ⥤ Type v)) : grothendieck_topology C :=
  Inf (finest_topology_single '' Ps)

/-- Check that if `P ∈ Ps`, then `P` is indeed a sheaf for the finest topology on `Ps`. -/
theorem sheaf_for_finest_topology {C : Type u} [category C] {P : Cᵒᵖ ⥤ Type v}
    (Ps : set (Cᵒᵖ ⥤ Type v)) (h : P ∈ Ps) : presieve.is_sheaf (finest_topology Ps) P :=
  sorry

/--
Check that if each `P ∈ Ps` is a sheaf for `J`, then `J` is a subtopology of `finest_topology Ps`.
-/
theorem le_finest_topology {C : Type u} [category C] (Ps : set (Cᵒᵖ ⥤ Type v))
    (J : grothendieck_topology C) (hJ : ∀ (P : Cᵒᵖ ⥤ Type v), P ∈ Ps → presieve.is_sheaf J P) :
    J ≤ finest_topology Ps :=
  sorry

/--
The `canonical_topology` on a category is the finest (largest) topology for which every
representable presheaf is a sheaf.

See https://stacks.math.columbia.edu/tag/00ZA
-/
def canonical_topology (C : Type u) [category C] : grothendieck_topology C :=
  finest_topology (set.range (functor.obj yoneda))

/-- `yoneda.obj X` is a sheaf for the canonical topology. -/
theorem is_sheaf_yoneda_obj {C : Type u} [category C] (X : C) :
    presieve.is_sheaf (canonical_topology C) (functor.obj yoneda X) :=
  fun (Y : C) (S : sieve Y) (hS : S ∈ coe_fn (canonical_topology C) Y) =>
    sheaf_for_finest_topology (set.range (functor.obj yoneda)) (set.mem_range_self X) S hS

/-- A representable functor is a sheaf for the canonical topology. -/
theorem is_sheaf_of_representable {C : Type u} [category C] (P : Cᵒᵖ ⥤ Type v) [representable P] :
    presieve.is_sheaf (canonical_topology C) P :=
  presieve.is_sheaf_iso (canonical_topology C) representable.w
    (is_sheaf_yoneda_obj (representable.X P))

/--
A subcanonical topology is a topology which is smaller than the canonical topology.
Equivalently, a topology is subcanonical iff every representable is a sheaf.
-/
def subcanonical {C : Type u} [category C] (J : grothendieck_topology C) := J ≤ canonical_topology C

namespace subcanonical

/-- If every functor `yoneda.obj X` is a `J`-sheaf, then `J` is subcanonical. -/
theorem of_yoneda_is_sheaf {C : Type u} [category C] (J : grothendieck_topology C)
    (h : ∀ (X : C), presieve.is_sheaf J (functor.obj yoneda X)) : subcanonical J :=
  le_finest_topology (set.range (functor.obj yoneda)) J
    fun (P : Cᵒᵖ ⥤ Type v) (H : P ∈ set.range (functor.obj yoneda)) =>
      Exists.dcases_on H fun (X : C) (H_h : functor.obj yoneda X = P) => Eq._oldrec (h X) H_h

/-- If `J` is subcanonical, then any representable is a `J`-sheaf. -/
theorem is_sheaf_of_representable {C : Type u} [category C] {J : grothendieck_topology C}
    (hJ : subcanonical J) (P : Cᵒᵖ ⥤ Type v) [representable P] : presieve.is_sheaf J P :=
  presieve.is_sheaf_of_le P hJ (is_sheaf_of_representable P)

end Mathlib


import Std

namespace LeanSAT

/-- CNF variable

NOTE: Unlike DIMACS, 0 is a valid variable. See `Var.toDIMACS`.
-/
def Var := Nat
deriving Inhabited, DecidableEq, Hashable, Repr, ToString

namespace Var

/-- Allow nat literals `5392` as notation for variables -/
instance : OfNat Var n := ⟨n⟩
end Var

/-- CNF literal -/
inductive Literal
| pos (v : Var) | neg (v : Var)
deriving Inhabited, DecidableEq, Hashable, Repr

namespace Literal

/-- The literal's variable -/
def var : Literal → Var
| pos v => v | neg v => v

/-- True iff the literal is `.pos v` -/
def isPos : Literal → Bool
| pos _ => true | neg _ => false

/-- True iff the literal is `.neg v` -/
def isNeg (l) := not (isPos l)

def not : Literal → Literal
| pos v => neg v
| neg v => pos v

/-- Automatically lift variables to positive literals -/
instance : Coe Var Literal := ⟨.pos⟩
/-- Allow literals to be written as nat constants -/
instance : OfNat Literal n := ⟨show Var from n⟩

instance : ToString Literal where
  toString | pos v => s!"{v}"
           | neg v => s!"¬{v}"

end Literal

/-- (Partial) assignment to the variables of a formula -/
def Assn := Std.HashMap Var Bool

namespace Assn

@[simp] def hasTrue   (v : Var) (a : Assn) : Bool := a.find? v = some true
@[simp] def hasFalse  (v : Var) (a : Assn) : Bool := a.find? v = some false
@[simp] def undecided (v : Var) (a : Assn) : Bool := a.find? v = none

def litTrue       (l : Literal) (a : Assn) : Bool := a.find? l.var = some l.isPos
def litFalse      (l : Literal) (a : Assn) : Bool := a.find? l.var = some l.isNeg
def litUndecided  (l : Literal) (a : Assn) : Bool := a.find? l.var = none

@[simp] theorem litTrue_pos : litTrue (.pos v) a = hasTrue v a := rfl
@[simp] theorem litTrue_neg : litTrue (.neg v) a = hasFalse v a := rfl
@[simp] theorem litFalse_pos : litFalse (.pos v) a = hasFalse v a := rfl
@[simp] theorem litFalse_neg : litFalse (.neg v) a = hasTrue v a := rfl
@[simp] theorem litUndecided_pos : litUndecided (.pos v) a = undecided v a := rfl
@[simp] theorem litUndecided_neg : litUndecided (.neg v) a = undecided v a := rfl

def insertLit (l : Literal) (a : Assn) : Assn :=
  a.insert l.var l.isPos

def toList (a : Assn) : List Literal :=
  Std.HashMap.toList a |>.map (fun (v,pos) => if pos then .pos v else .neg v)

instance : ToString Assn :=
  ⟨fun assn => assn.toList |>.map toString |> String.intercalate " "⟩

end Assn

/-- CNF clause: just a list of literals -/
structure Clause where
  lits : List Literal
deriving Inhabited, DecidableEq, Hashable, Repr

namespace Clause

/-- ⊥ / false clause -/
def empty : Clause := ⟨[]⟩

/-- Check whether any literals in `c` are set true by `a` -/
def eval (a : Assn) (c : Clause) : Bool :=
  c.lits.any a.litTrue

@[simp]
theorem eval_nil : eval a ⟨[]⟩ = false
  := by
  simp [eval, List.any, List.foldr]

@[simp]
theorem eval_cons : eval a ⟨l::ls⟩ = (a.litTrue l || eval a ⟨ls⟩)
  := by
  simp [eval, List.any, List.foldr]

instance : OfNat Clause n := ⟨(⟨[.pos n]⟩)⟩
instance : Coe Literal Clause := ⟨(⟨[·]⟩)⟩
instance : Coe (List Literal) Clause := ⟨(⟨·⟩)⟩

instance : ToString Clause where
  toString | ⟨lits⟩ => toString lits

end Clause

/-- CNF formula: a collection of clauses.

This structure is used for formalizing lemmas about sat/unsat
reductions and the likes. -/
structure Formula where
  clauses : List Clause
deriving DecidableEq, Repr

namespace Formula

def numVars : Formula → Nat
| ⟨clauses⟩ =>
  clauses.filterMap (·.lits.map (β := Nat) Literal.var |>.maximum?)
  |>.maximum?.map Nat.succ |>.getD 0

def vars : Formula → List Var
| ⟨clauses⟩ => Id.run do
  let mut set := Std.HashMap.empty
  for c in clauses do
    for l in c.lits do
      set := set.insert l.var ()
  return set.toList.map (·.1)

/-- ⊤ / true Formula -/
def empty : Formula := ⟨[]⟩

/-- Check whether all clauses in `c` are satisfied by `a` -/
def eval (a : Assn) (c : Formula) : Bool :=
  c.clauses.all (·.eval a)

@[simp]
theorem eval_nil : eval a ⟨[]⟩ = true
  := by
  simp [eval, List.all, List.foldr]

@[simp]
theorem eval_cons : eval a ⟨c::cs⟩ = (c.eval a && eval a ⟨cs⟩)
  := by
  simp [eval, List.all, List.foldr]

/-- Formula `c` is satisfiable if there exists a variable assignment
on which it is satisfied. -/
def satisfiable (c : Formula) := ∃ a, c.eval a = true

/-- Formula `c` is unsatisfiable iff there does not exist a variable
assignment on which it is satisfied. -/
def unsat (c : Formula) := ¬c.satisfiable

instance : Coe Clause Formula := ⟨(⟨[·]⟩)⟩
instance : OfNat Formula n := ⟨Literal.pos n⟩

end Formula

/-! CNF notation -/
namespace Notation

scoped notation:30 a:31 " ∨ " b:30 => Clause.mk (List.append (Clause.lits a) (Clause.lits b))
scoped notation a "∧" b => Formula.mk (List.append (Formula.clauses a) (Formula.clauses b))
scoped notation:max "¬" l:40 => Literal.not l

example : Literal := 5
example : Literal := ¬5
example : Clause  := ¬5 ∨ ¬10
example : Formula := (¬5 ∨ ¬10) ∧ 20 ∧ ¬30

end Notation


import algebraic_topology.simplicial_object
import algebraic_topology.simplicial_set

open category_theory category_theory.limits opposite
open_locale simplicial

noncomputable theory

universes w v u

namespace sSet

@[simps]
def binary_product (X Y : sSet) : sSet :=
{ obj := λ Δ, X.obj Δ × Y.obj Δ,
  map := λ Δ₁ Δ₂ θ s, (X.map θ s.1, Y.map θ s.2),
  map_id' := λ Δ, begin
    ext1 x,
    simp only [functor_to_types.map_id_apply, prod.mk.eta, types_id_apply],
  end,
  map_comp' := λ Δ₁ Δ₂ Δ₃ θ₁ θ₂, begin
    ext1 x,
    simp only [functor_to_types.map_comp_apply, types_comp_apply],
  end, }

end sSet

namespace category_theory

namespace simplicial_object

variables {C : Type u} [category.{v} C]

/-def Type_inclusion : Type v ⥤ Type (max w v) :=
{ obj := ulift.{w v},
  map := λ X Y f x, ulift.up (f (ulift.down x)),
  map_id' := λ X, by { ext, refl, },
  map_comp' := λ X Y Z f g, by { ext, refl, }, }

def yoneda' {C : Type u} [category.{v} C] :
  C ⥤ (Cᵒᵖ ⥤ Type (max w v)) :=
yoneda ⋙ (whiskering_right _ _ _).obj Type_inclusion-/

namespace sHom

/-- K ⊗ X ⟶ Y -/
@[ext]
structure bihom (K : sSet.{w}) (X Y : simplicial_object C) :=
(φ : Π Δ, K.obj Δ → (X.obj Δ ⟶ Y.obj Δ))
(naturality' : ∀ (Δ₁ Δ₂ : simplex_categoryᵒᵖ)
  (θ : Δ₁ ⟶ Δ₂) (k : K.obj Δ₁), φ Δ₁ k ≫ Y.map θ = X.map θ ≫ φ Δ₂ (K.map θ k))

namespace bihom

restate_axiom naturality'
attribute [reassoc] naturality

@[simp]
def map₁ {K L : sSet} (α : K ⟶ L) (X Y : simplicial_object C)
  (B : bihom L X Y) : bihom K X Y :=
{ φ := λ Δ k, B.φ Δ (α.app Δ k),
  naturality' := λ Δ₁ Δ₂ θ k, begin
    rw naturality,
    congr,
    exact congr_fun (α.naturality θ).symm k,
  end, }

end bihom

end sHom

@[simps]
def sHom (X Y : simplicial_object C) : sSet.{v} :=
{ obj := λ Δ, sHom.bihom (yoneda.obj Δ.unop) X Y,
  map := λ Δ₁ Δ₂ θ, sHom.bihom.map₁ (yoneda.map θ.unop) X Y,
  map_id' := λ Δ, begin
    rw [unop_id, yoneda.map_id],
    ext,
    simp only [sHom.bihom.map₁, nat_trans.id_app, types_id_apply],
  end,
  map_comp' := λ Δ₁ Δ₂ Δ₃ θ₁ θ₂, begin
    rw [unop_comp, yoneda.map_comp],
    ext,
    simp only [sHom.bihom.map₁, functor_to_types.comp, types_comp_apply],
  end }

def sHom₀ (X Y : simplicial_object C) : (sHom X Y) _[0] ≃ (X ⟶ Y) :=
{ to_fun := λ B,
  { app := λ Δ, B.φ Δ (simplex_category.hom.mk (order_hom.const _ 0)),
    naturality' := λ Δ₁ Δ₂ θ, by simpa only [B.naturality], },
  inv_fun := λ f,
  { φ := λ Δ s, f.app Δ,
    naturality' := λ Δ₁ Δ₂ θ k, by rw f.naturality, },
  left_inv := λ f, begin
    ext Δ k,
    simp only,
    congr,
    ext,
    simp only [fin.coe_fin_one],
  end,
  right_inv := λ B, by { ext Δ, refl, }, }

abbreviation tensor_exists (X : simplicial_object C) (K : sSet) :=
  ∀ (Δ : simplex_categoryᵒᵖ), has_coproduct (λ (k : K.obj Δ), X.obj Δ)

@[simps]
def tensor_sSet (X : simplicial_object C) (K : sSet)
  [tensor_exists X K] : simplicial_object C :=
{ obj := λ Δ, sigma_obj (λ (x : K.obj Δ), X.obj Δ),
  map := λ Δ₁ Δ₂ θ, sigma.desc
    (λ x, X.map θ ≫ sigma.ι (λ (x : K.obj Δ₂), X.obj Δ₂) (K.map θ x)),
  map_id' := λ Δ, begin
    ext k,
    discrete_cases,
    erw [colimit.ι_desc, cofan.mk_ι_app, X.map_id, category.id_comp,
      category.comp_id, K.map_id],
    refl,
  end,
  map_comp' := λ Δ₁ Δ₂ Δ₃ θ₁ θ₂, begin
    ext k,
    discrete_cases,
    rw K.map_comp,
    simpa only [X.map_comp, category.assoc, colimit.ι_desc, cofan.mk_ι_app,
      colimit.ι_desc_assoc],
  end, }

namespace tensor_sSet

@[simps]
def map₂ (X : simplicial_object C) {K L : sSet} (f : K ⟶ L)
  [tensor_exists X K] [tensor_exists X L] :
  X.tensor_sSet K ⟶ X.tensor_sSet L :=
{ app := λ Δ, sigma.desc (λ k, sigma.ι (λ l, X.obj Δ) (f.app Δ k)),
  naturality' := λ Δ₁ Δ₂ θ, begin
    ext k,
    discrete_cases,
    simp only [tensor_sSet_map, colimit.ι_desc_assoc, cofan.mk_ι_app,
      category.assoc, colimit.ι_desc],
    congr,
    exact congr_fun (f.naturality θ) k,
  end, }

lemma map₂_id (X : simplicial_object C) (K : sSet)
  [tensor_exists X K] :
  map₂ X (𝟙 K) = 𝟙 _ :=
begin
  ext k,
  discrete_cases,
  dsimp,
  simp only [colimit.ι_desc, cofan.mk_ι_app, category.comp_id],
end

lemma map₂_comp (X : simplicial_object C) {K L M : sSet} (f₁ : K ⟶ L) (f₂ : L ⟶ M)
  [tensor_exists X K] [tensor_exists X L] [tensor_exists X M] :
  map₂ X (f₁ ≫ f₂) = map₂ X f₁ ≫ map₂ X f₂ :=
begin
  ext k,
  dsimp,
  simp only [colimit.ι_desc, cofan.mk_ι_app, colimit.ι_desc_assoc],
end

@[simps]
def map₁ {X Y : simplicial_object C} (g : X ⟶ Y) (K : sSet)
  [tensor_exists X K] [tensor_exists Y K] :
  X.tensor_sSet K ⟶ Y.tensor_sSet K :=
{ app := λ Δ, limits.sigma.map (λ k, g.app Δ),
  naturality' := λ Δ₁ Δ₂ θ, begin
    ext k,
    simp only [tensor_sSet_map, colimit.ι_desc_assoc, cofan.mk_ι_app,
      category.assoc, ι_colim_map, discrete.nat_trans_app,
      nat_trans.naturality_assoc, ι_colim_map_assoc, colimit.ι_desc],
  end, }

lemma map₁₂ {X Y : simplicial_object C} {K L : sSet} (g : X ⟶ Y) (f : K ⟶ L)
  [tensor_exists X K] [tensor_exists Y K]
  [tensor_exists X L] [tensor_exists Y L] :
  map₁ g K ≫ map₂ Y f = map₂ X f ≫ map₁ g L :=
begin
  ext k,
  simp only [nat_trans.comp_app, map₁_app, map₂_app, ι_colim_map_assoc,
    discrete.nat_trans_app, colimit.ι_desc, cofan.mk_ι_app,
    colimit.ι_desc_assoc, ι_colim_map],
end

lemma map₁_id (X : simplicial_object C) (K : sSet)
  [tensor_exists X K] :
  map₁ (𝟙 X) K = 𝟙 _ :=
begin
  ext k,
  dsimp,
  simp only [ι_colim_map, discrete.nat_trans_app, category.comp_id],
  apply category.id_comp,
end

lemma map₁_comp {X Y Z : simplicial_object C} (g₁ : X ⟶ Y) (g₂ : Y ⟶ Z) (K : sSet)
  [tensor_exists X K] [tensor_exists Y K] [tensor_exists Z K] :
  map₁ (g₁ ≫ g₂) K = map₁ g₁ K ≫ map₁ g₂ K :=
begin
  ext k,
  dsimp,
  simp only [ι_colim_map_assoc, discrete.nat_trans_app, ι_colim_map, category.assoc],
end

@[simps]
def functor [hC : has_coproducts.{w} C] : sSet.{w} ⥤ simplicial_object C ⥤ simplicial_object C :=
{ obj := λ K,
  { obj := λ X, X.tensor_sSet K,
    map := λ X Y g, map₁ g K,
    map_id' := λ X, map₁_id X K,
    map_comp' := λ X Y Z g₁ g₂, map₁_comp g₁ g₂ K, },
  map := λ K L f,
  { app := λ X, map₂ X f,
    naturality' := λ X Y g, map₁₂ g f, },
  map_id' := λ K, by { ext1, ext1 X, exact map₂_id X K, },
  map_comp' := λ K L M f₁ f₂, by { ext1, ext1 X, exact map₂_comp X f₁ f₂, }, }

@[simps]
def universal_property (K : sSet) (X Y : simplicial_object C) [tensor_exists X K] :
  sHom.bihom K X Y ≃ (X.tensor_sSet K ⟶ Y) :=
{ to_fun := λ B,
  { app := λ Δ, sigma.desc (B.φ Δ),
    naturality' := λ Δ₁ Δ₂ θ, begin
      ext k,
      simp only [tensor_sSet_map, colimit.ι_desc_assoc, cofan.mk_ι_app,
        category.assoc, colimit.ι_desc, B.naturality],
    end, },
  inv_fun := λ f,
  { φ := λ Δ k, (by exact sigma.ι (λ l, X.obj Δ) k) ≫ f.app Δ,
    naturality' := λ Δ₁ Δ₂ θ k, by simp only [← f.naturality, category.assoc, tensor_sSet_map,
        colimit.ι_desc_assoc, cofan.mk_ι_app], },
  left_inv := λ B, begin
    ext1,
    simp only [colimit.ι_desc, cofan.mk_ι_app],
  end,
  right_inv := λ f, begin
    ext Δ k,
    discrete_cases,
    simp only [colimit.ι_desc, cofan.mk_ι_app],
  end, }

/- triple functoriality -/

/- compatibility between `universal_property` when K is the terminal object and sHom₀ -/

@[simps]
def binary_product_compatibility (K L : sSet) (X Y : simplicial_object C)
  [tensor_exists Y (K.binary_product L)] [tensor_exists X L]:
  sHom.bihom (K.binary_product L) X Y ≃ sHom.bihom K (X.tensor_sSet L) Y :=
{ to_fun := λ B,
  { φ := λ Δ k, sigma.desc (λ l, B.φ Δ (k, l)),
    naturality' := λ Δ₁ Δ₂ θ k, begin
      ext j,
      discrete_cases,
      simp only [colimit.ι_desc_assoc, cofan.mk_ι_app, tensor_sSet_map,
        category.assoc, colimit.ι_desc, B.naturality, sSet.binary_product_map],
    end, },
  inv_fun := λ B,
  { φ := λ Δ kl, (by exact sigma.ι (λ (l : L.obj Δ), X.obj Δ) kl.2) ≫ B.φ Δ kl.1,
    naturality' := λ Δ₁ Δ₂ θ kl, begin
      simpa only [B.naturality, category.assoc, tensor_sSet_map, colimit.ι_desc_assoc,
        cofan.mk_ι_app],
    end},
  left_inv := λ B, begin
    ext1,
    simp only [colimit.ι_desc, cofan.mk_ι_app, prod.mk.eta],
  end,
  right_inv := λ B, begin
    ext Δ k,
    discrete_cases,
    simp only [colimit.ι_desc, cofan.mk_ι_app],
  end, }

end tensor_sSet

end simplicial_object

end category_theory


-- WIP: only 1 lemma to prove: addSubSup.tail.sup

-- Tested with:
-- leanprover/lean4:nightly unchanged - Lean (version 4.0.0-nightly-2023-01-28, commit e37f209c1a2a, Release)

import Std.Data.AssocList
import Std.Data.List.Lemmas
import Std.Classes.BEq

namespace MWE9

theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = if c then a else b := by cases c <;> rfl

theorem cond_decide {α} (p : Prop) [Decidable p] (t e : α) : cond (decide p) t e = if p then t else e := by
  by_cases p <;> simp [*]

-- https://leanprover.zulipchat.com/#narrow/stream/270676-lean4/topic/Problems.20simplifying.20.20conditions.20with.20hypotheses/near/324212540
@[simp] theorem beq_eq_eq [DecidableEq α] (x y : α) :
  (x == y) = decide (x = y) := rfl

abbrev Strings := List String

instance : Repr (Std.AssocList String Strings) where reprPrec s n := s.toList.repr n

def addDecl (s: Std.AssocList String Strings) (d: String) : Std.AssocList String Strings :=
match s.contains d with
| true => s
| false => .cons d [] s

theorem addDecl.added (s: Std.AssocList String Strings) (d: String): (addDecl s d).contains d
:= by
  simp [addDecl]
  split <;> simp
  next x heq => simp_all

theorem addDecl.cons (s: Std.AssocList String Strings) (d: String): (addDecl s d).isEmpty = false
:= by
  simp [addDecl]
  split <;> simp [List.isEmpty]
  . case h_1 x heq =>
    split <;> simp_all

theorem addDecl.after (s: Std.AssocList String Strings) (x y: String): s.contains x → (addDecl s y).contains x
:= by
  intro h
  simp [Std.AssocList.contains, addDecl] at h ⊢
  apply Exists.elim h
  split <;> simp_all
  done

def addSubSup: String → String → Std.AssocList String Strings → Std.AssocList String Strings
| sub, sup, .nil            => .cons sub [sup] .nil
| sub, sup, .cons a as tail => bif a = sub then .cons sub (as.insert sup) tail else .cons a as (addSubSup sub sup tail)

@[simp] theorem addSubSup.sub (sub sup: String) (ss: Std.AssocList String Strings): (addSubSup sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case cons key value tail tail_ih =>
    simp [addSubSup, cond_eq_ite]
    by_cases key = sub
    . case pos h =>
      simp [h]
    . case neg h =>
      simp [h]
      apply tail_ih

@[simp] theorem addSubSup.exists.sub (sub sup: String) (tail: Std.AssocList String Strings)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sub
:= by
  induction tail <;> simp_all
  . case cons key value t ih =>
    simp [addSubSup, cond_eq_ite]
    by_cases key = sub
    . case pos h =>
      simp [h]
    . case neg h =>
      simp [h]
      apply ih

def addBoth (sub sup: String) (ss: Std.AssocList String Strings) : Std.AssocList String Strings :=
  let ss' := addDecl ss sup
  addSubSup sub sup ss'

@[simp] theorem addSubSup.more.sub
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sub)
  (other: Std.AssocList String Strings)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup other) ∧ x.fst = sub
:= by
  exact addSubSup.exists.sub sub sup other

@[simp] theorem addSubSup.tail.sup
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup)
: ∃ x, x ∈ Std.AssocList.toList tail ∧ x.fst = sup
:= by
  induction tail <;> simp [*]
  . case nil =>
    rw [addSubSup] at h
    let ⟨ x, p, eq ⟩ := h
    sorry
  . case cons key value t1 ih =>
    by_cases key = sup <;> simp [*]
    . case neg hs1 =>
      simp [addSubSup, cond_eq_ite, hs1] at h
      by_cases key = sub <;> simp_all
      . case neg hs2 =>
        sorry

@[simp] theorem addSubSup.key_value
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons key value tail)) ∧ x.fst = sup
:= by
  simp [addSubSup, cond_eq_ite]
  by_cases key = sub <;> simp_all
  . case pos h1 =>
    by_cases sub = sup <;> simp_all
    . case neg =>
      exact addSubSup.tail.sup sub sup tail h

@[simp] theorem addSubSup.cons
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sup)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧ x.fst = sup
:= by
  simp [addSubSup, cond_eq_ite]
  by_cases sup = sub <;> simp_all

@[simp] theorem addSubSup.cons2
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] tail)) ∧ x.fst = sup)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup (Std.AssocList.cons sup [] (Std.AssocList.cons key value tail))) ∧ x.fst = sup
:= by
  simp [addSubSup, cond_eq_ite]
  by_cases sup = sub <;> simp_all

@[simp] theorem addBoth2SubSup1
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup tail) ∧ x.fst = sub
:= by
  simp [addBoth] at h
  exact addSubSup.more.sub sub sup (addDecl tail sup) h tail

@[simp] theorem addBoth2SubSup2
  (sub sup: String)
  (tail: Std.AssocList String Strings)
  (h: ∃ x, x ∈ Std.AssocList.toList (addBoth sub sup tail) ∧ x.fst = sub)
  (other: Std.AssocList String Strings)
: ∃ x, x ∈ Std.AssocList.toList (addSubSup sub sup other) ∧ x.fst = sub
:= by
  have ht := addBoth2SubSup1 sub sup tail h
  exact addSubSup.more.sub sub sup tail ht other

theorem addBoth.sub_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sub
:= by
  induction ss <;> simp_all
  . case nil =>
    simp [addBoth, addDecl, addSubSup, cond_eq_ite]
    split <;> simp_all
  . case cons =>
    simp [addBoth, addDecl]

theorem addBoth.sup_eq (sub sup: String) (ss: Std.AssocList String Strings)
: (addBoth sub sup ss).contains sup
:= by
  simp [addBoth]
  simp [addDecl]
  induction ss <;> simp [*]
  . case nil =>
    simp [addSubSup, cond_eq_ite]
    by_cases sup = sub <;> simp [*]
  . case cons key value tail tail_ih =>
    simp [addDecl, cond_eq_ite]
    by_cases key = sup <;> simp [*]
    . case pos h1 =>
      simp [addSubSup, cond_eq_ite] at tail_ih ⊢
      by_cases sup = sub <;> simp [*]
    . case neg h1 =>
      split <;> simp_all

end MWE9


/- Defines very basic lemmas for vector -/
import data.vector

universe variables u

namespace vector

variable {α : Type u}
variable {n : ℕ}

@[simp]
theorem length_to_list : ∀ (x : vector α n), x.to_list.length = n
| ⟨ l, p ⟩ := p

end vector


import ring_theory.ideals data.equiv.algebra

#print relator.bi_unique

variables {α : Type*} {β : Type*} (R : α → β → Prop)

namespace relator
lemma rel_exists_unique_of_total [bi_total R] [bi_unique R] :
  ((R ⇒ iff) ⇒ iff) (λp, ∃! i, p i) (λq, ∃! i, q i) :=
λ p q h, rel_exists_of_total R $
  λ a b r, rel_and (h r) $ rel_forall_of_total R $
    λ c d s, rel_imp (h s) (rel_eq R s r)
end relator

namespace equiv

protected def rel (f : α ≃ β) (a : α) (b : β) : Prop := f a = b

theorem symm_rel (f : α ≃ β) {a : α} {b : β} : f.symm.rel b a ↔ f.rel a b :=
f.symm_apply_eq.trans eq_comm

open relator
theorem rel_left_unique (f : α ≃ β) : left_unique f.rel :=
λ a₁ b a₂ h, by rintro ⟨⟩; exact f.bijective.1 h

theorem rel_right_unique (f : α ≃ β) : right_unique f.rel :=
λ a₁ b a₂, by rintro ⟨⟩ ⟨⟩; refl

instance rel_bi_unique (f : α ≃ β) : bi_unique f.rel :=
⟨f.rel_left_unique, f.rel_right_unique⟩

instance rel_left_total (f : α ≃ β) : left_total f.rel := λ a, ⟨_, rfl⟩
instance rel_right_total (f : α ≃ β) : right_total f.rel := f.bijective.2
instance rel_bi_total (f : α ≃ β) : bi_total f.rel := by split; apply_instance

end equiv

namespace ring_equiv
variables [ring α] [ring β]
instance (α β) [ring α] [ring β] : has_coe_to_fun (α ≃r β) :=
⟨λ_, α → β, λe, e.to_equiv⟩

@[simp] theorem apply_inverse_apply (e : α ≃r β) (x : β) : e (e.symm x) = x :=
e.to_equiv.apply_inverse_apply x

@[simp] theorem inverse_apply_apply (e : α ≃r β) (x : α) : e.symm (e x) = x :=
e.to_equiv.inverse_apply_apply x

def {u v} ideal_comap {α : Type u} {β : Type v} [comm_ring α] [comm_ring β]
  (e : α ≃r β) (I : ideal β) : ideal α :=
{ carrier := e ⁻¹' I,
  zero  := by simp [is_ring_hom.map_zero e],
  add   := λ x y h₁ h₂, by simp [is_ring_hom.map_add e]; exact I.add_mem h₁ h₂,
  smul  := λ a x h, by simp [is_ring_hom.map_mul e]; exact I.smul_mem _ h }

@[simp] theorem mem_ideal_comap {α β} [comm_ring α] [comm_ring β]
  {e : α ≃r β} {I : ideal β} {r} : r ∈ ideal_comap e I ↔ e r ∈ I := iff.rfl

@[simp] theorem ideal_comap_top {α β} [comm_ring α] [comm_ring β]
  (e : α ≃r β) : ideal_comap e ⊤ = ⊤ := rfl

def ideal_congr {α β : Type*} [comm_ring α] [comm_ring β] (e : α ≃r β) :
  ideal α ≃ ideal β :=
{ to_fun := e.symm.ideal_comap,
  inv_fun := e.ideal_comap,
  left_inv := λ I, ideal.ext $ λ r, by simp,
  right_inv := λ I, ideal.ext $ λ r, by simp }

@[simp] theorem ideal_congr_apply {α β} [comm_ring α] [comm_ring β]
  (e : α ≃r β) (I : ideal α) : ideal_congr e I = e.symm.ideal_comap I := rfl

@[simp] theorem ideal_congr_symm_apply {α β} [comm_ring α] [comm_ring β]
  (e : α ≃r β) (I : ideal β) : (ideal_congr e).symm I = e.ideal_comap I := rfl

end ring_equiv

namespace relator

theorem rel_ideal_top
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R ≃r S) :
  f.ideal_congr.rel ⊤ ⊤ :=
ring_equiv.ideal_comap_top _

theorem rel_lt_ideal
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R ≃r S) :
  (f.ideal_congr.rel ⇒ f.ideal_congr.rel ⇒ iff) has_lt.lt has_lt.lt :=
λ I J (h : _=_) I' J' (h' : _=_), by substs h h'; exact _

theorem rel_is_maximal
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R ≃r S) :
  (f.ideal_congr.rel ⇒ iff) ideal.is_maximal ideal.is_maximal :=
λ I J h, rel_and
  (rel_not $ rel_eq f.ideal_congr.rel h $ rel_ideal_top _)
  (rel_forall_of_total f.ideal_congr.rel $
    λ I' J' h', rel_imp
      (rel_lt_ideal f h h')
      (rel_eq f.ideal_congr.rel h' (ring_equiv.ideal_comap_top _)))

end relator

theorem is_local_ring_congr
  {R S : Type*} [comm_ring R] [comm_ring S] (f : R ≃r S) :
  is_local_ring R ↔ is_local_ring S :=
relator.rel_exists_unique_of_total f.ideal_congr.rel $
λ I J, relator.rel_is_maximal f

#exit
instance qwer (F : Type u) [discrete_field F] :
module F (big_ideal F) := by apply_instance -- fails

set_option class.instance_max_depth 250
instance qwer (F : Type u) [discrete_field F] :
module F ((big_ideal F).quotient) := by apply_instance

#check ideal
#exit

instance ghjk (F : Type u) [discrete_field F] : module F (big_ideal F).quotient :=
sorry

private theorem big_basis.is_basis (F : Type u) [discrete_field F] : is_basis F (big_basis F) :=
sorry


/-
Copyright (c) 2020 Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.limits.shapes.equalizers
import Mathlib.category_theory.limits.shapes.reflexive
import Mathlib.category_theory.adjunction.default
import Mathlib.category_theory.monad.adjunction
import Mathlib.category_theory.monad.coequalizer
import Mathlib.PostPort

universes u₂ u₃ v₂ v₃ v₁ u₁ v₄ u₄

namespace Mathlib

/-!
# Adjoint lifting

This file gives two constructions for building left adjoints: the adjoint triangle theorem and the
adjoint lifting theorem.
The adjoint triangle theorem says that given a functor `U : B ⥤ C` with a left adjoint `F` such
that `ε_X : FUX ⟶ X` is a regular epi. Then for any category `A` with coequalizers of reflexive
pairs, a functor `R : A ⥤ B` has a left adjoint if (and only if) the composite `R ⋙ U` does.
Note that the condition on `U` regarding `ε_X` is automatically satisfied in the case when `U` is
a monadic functor, giving the corollary: `monadic_adjoint_triangle_lift`, i.e. if `U` is monadic,
`A` has reflexive coequalizers then `R : A ⥤ B` has a left adjoint provided `R ⋙ U` does.

The adjoint lifting theorem says that given a commutative square of functors (up to isomorphism):

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` and `V` are monadic and `A` has reflexive coequalizers, then if `R` has a left adjoint
then `Q` has a left adjoint.

## Implementation

It is more convenient to prove this theorem by assuming we are given the explicit adjunction rather
than just a functor known to be a right adjoint. In docstrings, we write `(η, ε)` for the unit
and counit of the adjunction `adj₁ : F ⊣ U` and `(ι, δ)` for the unit and counit of the adjunction
`adj₂ : F' ⊣ R ⋙ U`.

## TODO

Dualise to lift right adjoints through comonads (by reversing 1-cells) and dualise to lift right
adjoints through monads (by reversing 2-cells), and the combination.

## References
* https://ncatlab.org/nlab/show/adjoint+triangle+theorem
* https://ncatlab.org/nlab/show/adjoint+lifting+theorem
* Adjoint Lifting Theorems for Categories of Algebras (PT Johnstone, 1975)
* A unified approach to the lifting of adjoints (AJ Power, 1988)
-/

namespace category_theory

-- Hide implementation details in this namespace

namespace lift_adjoint

/--
To show that `ε_X` is a coequalizer for `(FUε_X, ε_FUX)`, it suffices to assume it's always a
coequalizer of something (i.e. a regular epi).
-/
def counit_coequalises {B : Type u₂} {C : Type u₃} [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (adj₁ : F ⊣ U) [(X : B) → regular_epi (nat_trans.app (adjunction.counit adj₁) X)] (X : B) : limits.is_colimit (limits.cofork.of_π (nat_trans.app (adjunction.counit adj₁) X) (counit_coequalises._proof_1 adj₁ X)) :=
  limits.cofork.is_colimit.mk' (limits.cofork.of_π (nat_trans.app (adjunction.counit adj₁) X) sorry)
    fun
      (s :
      limits.cofork (functor.map F (functor.map U (nat_trans.app (adjunction.counit adj₁) X)))
        (nat_trans.app (adjunction.counit adj₁) (functor.obj F (functor.obj U X)))) =>
      { val := subtype.val (regular_epi.desc' (nat_trans.app (adjunction.counit adj₁) X) (limits.cofork.π s) sorry),
        property := sorry }

/--
(Implementation)
To construct the left adjoint, we use the coequalizer of `F' U ε_Y` with the composite

`F' U F U X ⟶ F' U F U R F U' X ⟶ F' U R F' U X ⟶ F' U X`

where the first morphism is `F' U F ι_UX`, the second is `F' U ε_RF'UX`, and the third is `δ_F'UX`.
We will show that this coequalizer exists and that it forms the object map for a left adjoint to
`R`.
-/
def other_map {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A) (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U) (X : B) : functor.obj F' (functor.obj U (functor.obj F (functor.obj U X))) ⟶ functor.obj F' (functor.obj U X) :=
  functor.map F'
      (functor.map U
        (functor.map F (nat_trans.app (adjunction.unit adj₂) (functor.obj U X)) ≫
          nat_trans.app (adjunction.counit adj₁) (functor.obj R (functor.obj F' (functor.obj U X))))) ≫
    nat_trans.app (adjunction.counit adj₂) (functor.obj F' (functor.obj U X))

/--
`(F'Uε_X, other_map X)` is a reflexive pair: in particular if `A` has reflexive coequalizers then
it has a coequalizer.
-/
protected instance other_map.category_theory.is_reflexive_pair {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A) (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U) (X : B) : is_reflexive_pair (functor.map F' (functor.map U (nat_trans.app (adjunction.counit adj₁) X)))
  (other_map R F' adj₁ adj₂ X) := sorry

/--
Construct the object part of the desired left adjoint as the coequalizer of `F'Uε_Y` with
`other_map`.
-/
def construct_left_adjoint_obj {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A) (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U) [limits.has_reflexive_coequalizers A] (Y : B) : A :=
  limits.coequalizer (functor.map F' (functor.map U (nat_trans.app (adjunction.counit adj₁) Y)))
    (other_map R F' adj₁ adj₂ Y)

/-- The homset equivalence which helps show that `R` is a right adjoint. -/
def construct_left_adjoint_equiv {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A) (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U) [limits.has_reflexive_coequalizers A] [(X : B) → regular_epi (nat_trans.app (adjunction.counit adj₁) X)] (Y : A) (X : B) : (construct_left_adjoint_obj R F' adj₁ adj₂ X ⟶ Y) ≃ (X ⟶ functor.obj R Y) :=
  equiv.trans
    (equiv.trans
      (equiv.trans
        (limits.cofork.is_colimit.hom_iso
          (limits.colimit.is_colimit
            (limits.parallel_pair (functor.map F' (functor.map U (nat_trans.app (adjunction.counit adj₁) X)))
              (other_map R F' adj₁ adj₂ X)))
          Y)
        (equiv.subtype_congr (adjunction.hom_equiv adj₂ (functor.obj U X) Y) sorry))
      (equiv.subtype_congr (equiv.symm (adjunction.hom_equiv adj₁ (functor.obj U X) (functor.obj R Y))) sorry))
    (equiv.symm (limits.cofork.is_colimit.hom_iso (counit_coequalises adj₁ X) (functor.obj R Y)))

/-- Construct the left adjoint to `R`, with object map `construct_left_adjoint_obj`. -/
def construct_left_adjoint {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (F' : C ⥤ A) (adj₁ : F ⊣ U) (adj₂ : F' ⊣ R ⋙ U) [limits.has_reflexive_coequalizers A] [(X : B) → regular_epi (nat_trans.app (adjunction.counit adj₁) X)] : B ⥤ A :=
  adjunction.left_adjoint_of_equiv (fun (X : B) (Y : A) => construct_left_adjoint_equiv R F' adj₁ adj₂ Y X) sorry

end lift_adjoint

/--
The adjoint triangle theorem: Suppose `U : B ⥤ C` has a left adjoint `F` such that each counit
`ε_X : FUX ⟶ X` is a regular epimorphism. Then if a category `A` has coequalizers of reflexive
pairs, then a functor `R : A ⥤ B` has a left adjoint if the composite `R ⋙ U` does.

Note the converse is true (with weaker assumptions), by `adjunction.comp`.
See https://ncatlab.org/nlab/show/adjoint+triangle+theorem
-/
def adjoint_triangle_lift {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {U : B ⥤ C} {F : C ⥤ B} (R : A ⥤ B) (adj₁ : F ⊣ U) [(X : B) → regular_epi (nat_trans.app (adjunction.counit adj₁) X)] [limits.has_reflexive_coequalizers A] [is_right_adjoint (R ⋙ U)] : is_right_adjoint R :=
  is_right_adjoint.mk
    (lift_adjoint.construct_left_adjoint R (left_adjoint (R ⋙ U)) adj₁ (adjunction.of_right_adjoint (R ⋙ U)))
    (adjunction.adjunction_of_equiv_left
      (fun (X : B) (Y : A) =>
        lift_adjoint.construct_left_adjoint_equiv R (left_adjoint (R ⋙ U)) adj₁ (adjunction.of_right_adjoint (R ⋙ U)) Y X)
      sorry)

/--
If `R ⋙ U` has a left adjoint, the domain of `R` has reflexive coequalizers and `U` is a monadic
functor, then `R` has a left adjoint.
This is a special case of `adjoint_triangle_lift` which is often more useful in practice.
-/
def monadic_adjoint_triangle_lift {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] (U : B ⥤ C) [monadic_right_adjoint U] {R : A ⥤ B} [limits.has_reflexive_coequalizers A] [is_right_adjoint (R ⋙ U)] : is_right_adjoint R :=
  let R' : A ⥤ monad.algebra (left_adjoint U ⋙ U) := R ⋙ monad.comparison U;
  let this : is_right_adjoint (R' ⋙ functor.inv (monad.comparison U)) := adjunction.right_adjoint_of_comp;
  let this_1 : R' ⋙ functor.inv (monad.comparison U) ≅ R :=
    iso_whisker_left R (functor.fun_inv_id (monad.comparison U)) ≪≫ functor.right_unitor R;
  adjunction.right_adjoint_of_nat_iso this_1

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` has a left adjoint such that
each component of the counit is a regular epi.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
def adjoint_square_lift {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {D : Type u₄} [category D] (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D) (comm : U ⋙ R ≅ Q ⋙ V) [is_right_adjoint U] [is_right_adjoint V] [is_right_adjoint R] [(X : B) → regular_epi (nat_trans.app (adjunction.counit (adjunction.of_right_adjoint V)) X)] [limits.has_reflexive_coequalizers A] : is_right_adjoint Q :=
  let this : is_right_adjoint (Q ⋙ V) := adjunction.right_adjoint_of_nat_iso comm;
  adjoint_triangle_lift Q (adjunction.of_right_adjoint V)

/--
Suppose we have a commutative square of functors

      Q
    A → B
  U ↓   ↓ V
    C → D
      R

where `U` has a left adjoint, `A` has reflexive coequalizers and `V` is monadic.
Then `Q` has a left adjoint if `R` has a left adjoint.

See https://ncatlab.org/nlab/show/adjoint+lifting+theorem
-/
def monadic_adjoint_square_lift {A : Type u₁} {B : Type u₂} {C : Type u₃} [category A] [category B] [category C] {D : Type u₄} [category D] (Q : A ⥤ B) (V : B ⥤ D) (U : A ⥤ C) (R : C ⥤ D) (comm : U ⋙ R ≅ Q ⋙ V) [is_right_adjoint U] [monadic_right_adjoint V] [is_right_adjoint R] [limits.has_reflexive_coequalizers A] : is_right_adjoint Q :=
  let this : is_right_adjoint (Q ⋙ V) := adjunction.right_adjoint_of_nat_iso comm;
  monadic_adjoint_triangle_lift V


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison

! This file was ported from Lean 3 source module tactic.nontriviality
! leanprover-community/mathlib commit c93660aa62cc7be8026b707c31edcbc0ca018057
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Logic.Nontrivial

/-!
# The `nontriviality` tactic.

-/

namespace Tactic

/-- Tries to generate a `nontrivial α` instance by performing case analysis on
`subsingleton_or_nontrivial α`,
attempting to discharge the subsingleton branch using lemmas with `@[nontriviality]` attribute,
including `subsingleton.le` and `eq_iff_true_of_subsingleton`.
-/
unsafe def nontriviality_by_elim (α : expr) (lems : interactive.parse simp_arg_list) :
    tactic Unit := do
  let alternative ← to_expr ``(subsingleton_or_nontrivial $(α))
  let n ← get_unused_name "_inst"
  tactic.cases Alternative [n, n]
  (solve1 do
        reset_instance_cache
        apply_instance <|>
            interactive.simp none none ff lems [`nontriviality] (Interactive.Loc.ns [none])) <|>
      fail f! "Could not prove goal assuming `subsingleton {α}`"
  reset_instance_cache
#align tactic.nontriviality_by_elim tactic.nontriviality_by_elim

/- ./././Mathport/Syntax/Translate/Expr.lean:330:4: warning: unsupported (TODO): `[tacs] -/
/-- Tries to generate a `nontrivial α` instance using `nontrivial_of_ne` or `nontrivial_of_lt`
and local hypotheses.
-/
unsafe def nontriviality_by_assumption (α : expr) : tactic Unit := do
  let n ← get_unused_name "_inst"
  to_expr ``(Nontrivial $(α)) >>= assert n
  apply_instance <|> sorry
  reset_instance_cache
#align tactic.nontriviality_by_assumption tactic.nontriviality_by_assumption

end Tactic

namespace Tactic.Interactive

open Tactic

/- ./././Mathport/Syntax/Translate/Tactic/Mathlib/Core.lean:38:34: unsupported: setup_tactic_parser -/
/-- Attempts to generate a `nontrivial α` hypothesis.

The tactic first looks for an instance using `apply_instance`.

If the goal is an (in)equality, the type `α` is inferred from the goal.
Otherwise, the type needs to be specified in the tactic invocation, as `nontriviality α`.

The `nontriviality` tactic will first look for strict inequalities amongst the hypotheses,
and use these to derive the `nontrivial` instance directly.

Otherwise, it will perform a case split on `subsingleton α ∨ nontrivial α`, and attempt to discharge
the `subsingleton` goal using `simp [lemmas] with nontriviality`, where `[lemmas]` is a list of
additional `simp` lemmas that can be passed to `nontriviality` using the syntax
`nontriviality α using [lemmas]`.

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : 0 < a :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  assumption,
end
```

```
example {R : Type} [comm_ring R] {r s : R} : r * s = s * r :=
begin
  nontriviality, -- There is now a `nontrivial R` hypothesis available.
  apply mul_comm,
end
```

```
example {R : Type} [ordered_ring R] {a : R} (h : 0 < a) : (2 : ℕ) ∣ 4 :=
begin
  nontriviality R, -- there is now a `nontrivial R` hypothesis available.
  dec_trivial
end
```

```
def myeq {α : Type} (a b : α) : Prop := a = b

example {α : Type} (a b : α) (h : a = b) : myeq a b :=
begin
  success_if_fail { nontriviality α }, -- Fails
  nontriviality α using [myeq], -- There is now a `nontrivial α` hypothesis available
  assumption
end
```
-/
unsafe def nontriviality (t : parse texpr ?)
    (lems : parse (tk "using" *> simp_arg_list <|> pure [])) : tactic Unit := do
  let α ←
    match t with
      | some α => to_expr α
      | none =>
        (do
            let t ← mk_mvar
            let e ← to_expr ``(@Eq $(t) _ _)
            target >>= unify e
            return t) <|>
          (do
              let t ← mk_mvar
              let e ← to_expr ``(@LE.le $(t) _ _ _)
              target >>= unify e
              return t) <|>
            (do
                let t ← mk_mvar
                let e ← to_expr ``(@Ne $(t) _ _)
                target >>= unify e
                return t) <|>
              (do
                  let t ← mk_mvar
                  let e ← to_expr ``(@LT.lt $(t) _ _ _)
                  target >>= unify e
                  return t) <|>
                fail
                  "The goal is not an (in)equality, so you'll need to specify the desired `nontrivial α`\n      instance by invoking `nontriviality α`."
  nontriviality_by_assumption α <|> nontriviality_by_elim α lems
#align tactic.interactive.nontriviality tactic.interactive.nontriviality

add_tactic_doc
  { Name := "nontriviality"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.nontriviality]
    tags := ["logic", "type class"] }

end Tactic.Interactive