-- Copyright © 2019 François G. Dorais. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.

import .basic
import .monoid
import .group
import .action

namespace algebra

/-
signature command cannot handle operation parameters,
so we define category_sig manually; category_hom is missing.
-/
structure category_sig {α : Type*} (β : α → α → Type*) :=
(op (a b c : α) : β a b → β b c → β a c)
(id (a : α) : β a a)

namespace category_sig
variables {α : Type*} {β : α → α → Type*} (s : category_sig β)

@[signature_instance]
definition to_monoid (a : α) : monoid_sig (β a a) :=
{ op := s.op a a a
, id := s.id a
}

@[signature_instance]
definition to_left_action (a b : α) : left_action_sig (β a a) (β a b) :=
{ act := s.op a a b
}

@[signature_instance]
definition to_right_action (a b : α) : right_action_sig (β a a) (β b a) :=
{ act := s.op b a a
}

end category_sig

/- TODO: fix theory attribute to handle parameters correctly -/
class category {α : Type*} {β : α → α → Type*} (s : category_sig β) : Prop := intro ::
(assoc (a b c d) : identity.op_compatibility (s.op a c d) (s.op a b c) (s.op a b d) (s.op b c d))
(left_identity (a b) : identity.op_left_identity (s.op a a b) (s.id a))
(right_identity (a b) : identity.op_right_identity (s.op a b b) (s.id b))

attribute [identity_instance] category.assoc
attribute [identity_instance] category.left_identity
attribute [identity_instance] category.right_identity

namespace category
variables {α : Type*} {β : α → α → Type*} (s : category_sig β) [i : category s]

definition infer
[Π (a b c d), class.op_compatibility (s.op a c d) (s.op a b c) (s.op a b d) (s.op b c d)]
[Π (a b), class.op_left_identity (s.op a a b) (s.id a)]
[Π (a b), class.op_right_identity (s.op a b b) (s.id b)] : category s :=
category.intro
(λ _ _ _ _, op_compatibility _ _ _ _)
(λ _ _, op_left_identity _ _)
(λ _ _, op_right_identity _ _)

include i

instance to_monoid (a : α) : monoid (s.to_monoid a) := monoid.infer _

instance to_left_monoid_action (a b : α) : left_monoid_action (s.to_monoid a) (s.to_left_action a b) := left_monoid_action.infer _ _

instance to_right_monoid_action (a b : α) : right_monoid_action (s.to_monoid a) (s.to_right_action a b) := right_monoid_action.infer _ _

end category

end algebra

/- move to monoid when ready -/
namespace algebra

namespace monoid_sig
variables {α : Type*} (s : monoid_sig α)

@[signature_instance]
definition to_category : category_sig (λ (_ _ : unit), α) :=
{ op := λ _ _ _, s.op
, id := λ _, s.id
}

end monoid_sig

namespace monoid
variables {α : Type*} (s : monoid_sig α) [monoid s]

@[identity_instance]
theorem to_category_compatibility (a b c d : unit) : identity.op_compatibility (s.to_category.op a c d) (s.to_category.op a b c) (s.to_category.op a b d) (s.to_category.op b c d) :=
show identity.op_compatibility s.op s.op s.op s.op, from op_associative s.op

@[identity_instance]
theorem to_category_left_identity (a b : unit) : identity.op_left_identity (s.to_category.op a a b) (s.to_category.id a) :=
show identity.op_left_identity s.op s.id, from op_left_identity s.op s.id

@[identity_instance]
theorem to_category_right_identity (a b : unit) : identity.op_right_identity (s.to_category.op a b b) (s.to_category.id b) :=
show identity.op_right_identity s.op s.id, from op_right_identity s.op s.id

instance to_category : category s.to_category := category.infer _

end monoid

end algebra


/- Introduces typing contexts, which are lists of assumptions with associated
   multiplicities from an arbitrary semiring. -/

import tactic.ring
import tactic.abel
import algebra

import metastuff

/- In the QTT paper, this would be a "pre-precontext". -/
@[reducible]
def precontext (τ: Type) := list τ

/- In the QTT paper, this is the "precontext".
   τ is the Lean Type representing types of the embedded language.
   mult is the Lean Type representing elements of an arbitrary semiring,
   which describe the multiplicity of resources (how many times a resource
   can or will be used). -/
inductive context {τ mult: Type}: precontext τ → Type
| nil: context []
-- "You have a dependent pi (n) after a recursive arg (_ : context ns)
-- and Lean doesn't like this."
| cons {γ: precontext τ} (π: mult) (T: τ): context γ → context (T::γ)

notation `⟦`π`⬝`T`⟧::`Γ:90 := context.cons π T Γ

/- Indexes an assumption in the typing context. -/
inductive debrujin_idx {τ: Type}: precontext τ → τ → Type
infix ` ∋ `:55 := debrujin_idx
| ZVar: Π {γ: precontext τ} {T: τ},
  ----------
  (T::γ) ∋ T
| SVar: Π {γ: precontext τ} {T U: τ},
  γ ∋ T
  ----------
→ (U::γ) ∋ T
infix ` ∋ `:55 := debrujin_idx

namespace context

variable {τ: Type}
variables {mult: Type} [semiring mult]

def zeros: Π (γ: precontext τ), @context τ mult γ
| [] := nil
| (T::δ) := ⟦0⬝T⟧::(zeros δ)

instance {γ: precontext τ} : has_zero (@context τ mult γ) :=
  ⟨zeros γ⟩

@[unfold_] lemma zeros_cons {γ: precontext τ} {T: τ}
  : (0: @context τ mult (T::γ)) = ⟦(0: mult)⬝T⟧::(0: @context τ mult γ) := by refl

protected def add: Π {γ}, @context τ mult γ → @context τ mult γ → @context τ mult γ
| _ nil nil := nil
| _ (⟦π₁⬝T⟧::Γ₁) (⟦π₂⬝.(T)⟧::Γ₂) := ⟦(π₁+π₂)⬝T⟧::(add Γ₁ Γ₂)

instance {γ: precontext τ} : has_add (@context τ mult γ) :=
  ⟨context.add⟩

@[simp] lemma add_nil
  : (nil: @context τ mult []) + nil = nil := by refl

@[unfold_] lemma add_cons {γ} {Γ₁ Γ₂: @context τ mult γ} {π₁ π₂: mult} {T: τ}
  : ⟦π₁⬝T⟧::Γ₁ + ⟦π₂⬝T⟧::Γ₂ = ⟦(π₁+π₂)⬝T⟧::(Γ₁ + Γ₂) := by refl

/- addition makes a commutative monoid -/

@[simp] lemma zero_add
  : ∀ {γ} {Γ: @context τ mult γ},
    0 + Γ = Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { unfold has_zero.zero zeros at *,
    simp * with unfold_, show π+0=π,
    abel },
end

@[simp] lemma add_zero
  : ∀ {γ} {Γ: @context τ mult γ},
    Γ + 0 = Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { unfold has_zero.zero zeros at *,
    simp * with unfold_, show π+0=π,
    abel },
end

lemma add_comm
  : ∀ {γ} {Γ₁ Γ₂: @context τ mult γ},
    Γ₁ + Γ₂ = Γ₂ + Γ₁ :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, refl },
  { cases Γ₂ with _ π₂,
    simp * with unfold_ },
end

lemma add_assoc
  : ∀ {γ} {Γ₁ Γ₂ Γ₃: @context τ mult γ},
    (Γ₁ + Γ₂) + Γ₃ = Γ₁ + (Γ₂ + Γ₃) :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, cases Γ₃, refl },
  { cases Γ₂ with _ π₂,
    cases Γ₃ with _ π₃,
    simp * with unfold_ },
end

instance [h: semiring mult] {γ: precontext τ} : add_comm_monoid (@context τ mult γ) :=
{ add := context.add,
  zero := zeros γ,
  zero_add := @zero_add τ mult h γ,
  add_zero := @add_zero τ mult h γ,
  add_comm := @add_comm τ mult h γ,
  add_assoc := @add_assoc τ mult h γ }

protected def smul: Π {γ}, mult → @context τ mult γ → @context τ mult γ
| _ π nil := nil
| _ π (⟦π'⬝T⟧::Γ) := ⟦(π*π')⬝T⟧::(smul π Γ)

instance {γ: precontext τ} : has_scalar mult (@context τ mult γ) :=
  ⟨context.smul⟩

@[simp] lemma smul_nil {π: mult}
  : π • (nil: @context τ mult []) = nil := by refl

@[unfold_] lemma smul_cons {γ} {Γ: @context τ mult γ} {π π': mult} {T: τ}
  : π • ⟦π'⬝T⟧::Γ = ⟦(π*π')⬝T⟧::(π • Γ) := by refl

/- scalar multiplication (mult • context) makes a semimodule -/

@[simp] lemma one_smul
  : ∀ {γ} {Γ: @context τ mult γ},
    ((1: mult) • Γ: @context τ mult γ) = Γ :=
begin
  intros,
  induction Γ with γ π T Δ ih,
  { refl },
  { simp * with unfold_ },
end

@[simp] lemma zero_smul
  : ∀ {γ} {Γ: @context τ mult γ},
    ((0: mult) • Γ: @context τ mult γ) = 0 :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { simp * with unfold_ },
end

@[simp] lemma smul_zero
  : ∀ {γ} {π: mult},
    (π • 0: @context τ mult γ) = 0 :=
begin
  intros,
  induction γ with T γ ih,
  { refl },
  { unfold has_zero.zero zeros,
    unfold has_zero.zero zeros at ih,
    simp * with unfold_,
    show π*0=0, simp * },
end

@[sop_form] lemma smul_add
  : ∀ {γ} {π: mult} {Γ₁ Γ₂: @context τ mult γ},
    π • (Γ₁ + Γ₂) = π•Γ₁ + π•Γ₂ :=
begin
  intros,
  induction Γ₁ with γ₁ π₁ T₁ Γ₁ ih₁,
  { cases Γ₂, refl },
  { cases Γ₂ with _ π₂,
    simp [*, left_distrib] with unfold_ },
end

@[sop_form] lemma add_smul
  : ∀ {γ} {π₁ π₂: mult} {Γ: @context τ mult γ},
    (π₁ + π₂) • Γ = π₁•Γ + π₂•Γ :=
begin
  intros,
  induction Γ with γ π T Γ ih,
  { refl },
  { simp [*, right_distrib] with unfold_ },
end

lemma mul_smul
  : ∀ {γ} {π π': mult} {Γ: @context τ mult γ},
    (π * π') • Γ = π • (π' • Γ) :=
begin
  intros, induction Γ with γ π T Γ ih,
  { refl },
  { simp [*, mul_assoc] with unfold_ },
end

instance [h: semiring mult] {γ: precontext τ} : semimodule mult (@context τ mult γ) :=
{ one_smul := @one_smul τ mult h γ,
  zero_smul := @zero_smul τ mult h γ,
  smul_zero := @smul_zero τ mult h γ,
  smul_add := @smul_add τ mult h γ,
  add_smul := @add_smul τ mult h γ,
  mul_smul := @mul_smul τ mult h γ }

end context


import tactic

/--
  Specialized version of function.update.
-/
def function.update_ite
  {α β : Type}
  [decidable_eq α]
  (f : α → β)
  (a' : α) (b : β) (a : α) :=
  if a = a' then b else f a

lemma function.update_ite_comp
  {α α' β : Sort*}
  [decidable_eq α]
  (f : α' → β)
  (g : α → α')
  (i : α)
  (v : α') :
  f ∘ (function.update_ite g i v) =
    function.update_ite (f ∘ g) i (f v) :=
begin
  funext,
  simp only [function.comp_app],
  unfold function.update_ite,
  split_ifs; refl,
end

@[simp]
lemma function.update_ite_idem
  {α β : Type}
  [decidable_eq α]
  (f : α → β)
  (a : α)
  (x y : β)  :
  function.update_ite (function.update_ite f a x) a y =
    function.update_ite f a y :=
begin
  funext,
  unfold function.update_ite,
  split_ifs,
  {
    refl,
  },
  {
    refl,
  }
end

lemma function.update_ite_id
  {α : Type}
  [decidable_eq α]
  (x : α) :
  function.update_ite (id : α → α) x x = id :=
begin
  funext,
  unfold function.update_ite,
  split_ifs,
  {
    subst h,
    simp only [id.def],
  },
  {
    refl,
  }
end

lemma function.update_ite_not_mem_list
  {α β : Type}
  [decidable_eq α]
  (l : list α)
  (f : α → β)
  (a : α)
  (b : β)
  (h1 : a ∉ l) :
  l.map (function.update_ite f a b) = l.map f :=
begin
  induction l,
  case list.nil
  {
    simp only [list.map_nil],
  },
  case list.cons : l_hd l_tl l_ih
  {
    simp only [list.mem_cons_iff] at h1,
    push_neg at h1,
    dsimp at h1,
    cases h1,

    simp only [list.map],
    split,
    {
      unfold function.update_ite,
      split_ifs; tauto,
    },
    {
      exact l_ih h1_right,
    }
  },
end

lemma function.update_ite_not_mem_set
  {α β : Type}
  [decidable_eq α] [decidable_eq β]
  (S : finset α)
  (f : α → β)
  (a : α)
  (b : β)
  (h1 : a ∉ S) :
  finset.image (function.update_ite f a b) S = finset.image f S :=
begin
  induction S using finset.induction_on,
  case h₁
  {
    simp only [finset.image_empty],
  },
  case h₂ : S_a S_S S_1 S_ih
  {
    simp only [finset.mem_insert] at h1,
    push_neg at h1,
    dsimp at h1,
    cases h1,

    simp only [finset.image_insert],
    congr' 1,
    {
      unfold function.update_ite,
      split_ifs; tauto,
    },
    {
      exact S_ih h1_right,
    }
  },
end


import Pauline.Notation
import Pauline.Statics

open Pauline

def program := [sml|

  val loop = fn L => loop L

  fun div (n : int, d : int) : int =
    if n < d
    then 0
    else 1 + div (n-d, d)

]

def program_ctx : Context := sorry
def program_state : State := sorry

theorem div_tc
  : [smlprop|
      program_ctx ⊢ div : int * int -> int
    ]
  := by
  sorry

theorem div_thm
  : ∀ n d : Nat, d > 0 → ∃ q r : Nat,
    r < d ∧
    n = q * d + r ∧
    [smlprop|
      program_state ⊢ div (↑n, ↑d) ==>* program_state ⊢ ↑q
    ]
  := by
  intro n d h_d
  induction n using Nat.strongInductionOn
  case ind n ih =>
  if h : n < d then
    refine ⟨0, n, h, by simp, ?_⟩
    (calc
      (program_state, [sml_exp| div (↑n, ↑d)])
        ==>* (program_state, [sml_exp| 0 ]) := by sorry
      _ ==>* (program_state, [sml_exp| ↑0 ]) := ⟨0, rfl, rfl⟩
    )
  else
    have : n - d < n := Nat.sub_lt (Nat.lt_of_lt_of_le h_d (Nat.ge_of_not_lt h)) h_d
    have ⟨q,r,hr,hn,steps⟩ := ih (n-d) this
    have : n = (1+q) * d + r := by
      rw [Nat.add_mul, Nat.add_assoc, ←hn, Nat.one_mul, Nat.add_comm, Nat.sub_add_cancel (Nat.ge_of_not_lt h)]
    refine ⟨_, _, hr, this, ?_⟩
    (calc
             (program_state, [sml_exp| div (↑n, ↑d)])
        ==>* (program_state, [sml_exp| 1 + div (↑n-↑d,↑d)]) := by sorry
      _ ==>* (program_state, [sml_exp| 1 + ↑q ])            := by sorry -- ih
      _ ==>* (program_state, [sml_exp| ↑(1+q) ])            := by sorry
    )


/- ACL and MIdFF, Lean 2022 meeting at Icerm -/
import ring_theory.power_series.basic
import algebra_lemmas
import combinatorics_lemmas
import data.nat.choose.multinomial

/-! # Divided powers

Let `A` be a commutative ring and `I` be an ideal of `A`.
A *divided power* structure on `I` is the datum of operations `div_pow : ℕ → I → A`
satisfying relations that model the intuitive formula `div_pow n a = a ^ n / n.factorial` and
collected by the structure `divided_powers`.
To avoid coercions, we rather consider `div_pow : ℕ → A → A`, extended by 0.

## References

* P. Berthelot (1974), *Cohomologie cristalline des schémas de caractéristique $p$ > 0*,
Lectures notes in mathematics 407, Springer-Verlag.

* P. Berthelot and A. Ogus (1978), *Notes on crystalline cohomology*,
Princeton University Press.

* N. Roby (1963). « Lois polynomes et lois formelles en théorie des modules ». Annales scientifiques de l’École Normale Supérieure 80 (3): 213‑348. https://doi.org/10.24033/asens.1124.

* N. Roby (1968), *Construction de certaines algèbres à puissances divisées*,
Bulletin de la Société Mathématique de France, Tome 96, p. 97-113.
doi: https://doi.org/10.24033/bsmf.1661

* N. Roby (1966), *Sur l'algèbre des puissances divisées d'un module et le module de ses
différentielles*, Annales scientifiques de l'École Normale Supérieure, Série 3, Tome 83,no. 2,
p. 75-89.
doi: https://doi.org/10.24033/asens.1148

-/

section divided_powers_definition

/-- The divided power structure on an ideal I of a commutative ring A -/
@[ext] structure divided_powers {A : Type*} [comm_ring A] (I : ideal A) :=
(dpow : ℕ → A → A)
(dpow_null : ∀ {n x} (hx : x ∉ I), dpow n x = 0)
(dpow_zero : ∀ {x} (hx : x ∈ I), dpow 0 x = 1)
(dpow_one : ∀ {x} (hx : x ∈ I), dpow 1 x = x)
(dpow_mem : ∀ {n} (hn : n ≠ 0) {x} (hx : x ∈ I), dpow n x ∈ I)
(dpow_add : ∀ n {x y} (hx : x ∈ I) (hy : y ∈ I) , dpow n (x + y)
  = finset.sum (finset.range (n + 1)) (λ k, (dpow k x) * (dpow (n - k) y)))
(dpow_smul : ∀ n {a : A} {x} (hx : x ∈ I), dpow n (a * x) = (a ^ n) * (dpow n x))
(dpow_mul : ∀ m n {x} (hx : x ∈ I), (dpow m x) * (dpow n x) = (nat.choose (m+n) m) * dpow (m + n) x)
(dpow_comp : ∀ m {n} (hn : n ≠ 0) {x} (hx : x ∈ I),
  dpow m (dpow n x) = (mchoose m n) * dpow (m * n) x)

instance {A : Type*} [comm_ring A] (I : ideal A) :
  has_coe_to_fun (divided_powers I) (λ _, ℕ → A → A) :=
⟨λ hI, hI.dpow⟩

structure pd_ring (A : Type*) extends comm_ring A :=
(pd_ideal : ideal A)
(divided_powers : divided_powers pd_ideal)

end divided_powers_definition

namespace divided_powers

section basic_lemmas

variables {A : Type*} [comm_ring A] {I : ideal A}

def dpow_exp (hI : divided_powers I) (a : A) := power_series.mk (λ n, hI.dpow n a)

lemma add_dpow_exp (hI : divided_powers I) {a b : A} (ha : a ∈ I) (hb : b ∈ I) :
  hI.dpow_exp (a + b) = hI.dpow_exp (a) * hI.dpow_exp (b) :=
begin
  simp only [dpow_exp],
  ext,
  simp only [power_series.coeff_mk, power_series.coeff_mul],
  rw [hI.dpow_add n ha hb, finset.nat.sum_antidiagonal_eq_sum_range_succ_mk],
end

lemma eq_of_eq_on_ideal (hI : divided_powers I) (hI' : divided_powers I)
  (h_eq : ∀ (n : ℕ) {x : A} (hx : x ∈ I), hI.dpow n x = hI'.dpow n x ) : hI = hI' :=
begin
  ext n x,
  by_cases hx : x ∈ I,
  { exact h_eq n hx },
  { rw [hI.dpow_null hx, hI'.dpow_null hx] }
end

/- noncomputable
def dpow_of_dpow_exp (I : ideal A) (ε : I → power_series A) :
  ℕ → A → A := λ n,
  function.extend
    (λ (a : I), a.val)
    (λ a, power_series.coeff A n (ε a))
    (λ (a :A) , (0 : A))

-- Golfed version of definition
noncomputable def dpow_of_dpow_exp (I : ideal A) (ε : I → power_series A) : ℕ → A → A :=
λ n, function.extend (λ (a : I), (a : A)) (λ (a : I), power_series.coeff A n (ε a)) 0

def divided_powers_of_dpow_exp (I : ideal A) (ε : I → power_series A)
  (hε_add : ∀ (a b : I), ε(a + b) = ε(a) * ε(b))
  (hε_zero : ε(0) = 1) -/

variable (hI : divided_powers I)

/- Rewriting lemmas -/
lemma dpow_smul' (n : ℕ) {a : A} {x : A} (hx : x ∈ I) :
  hI.dpow n (a • x) = (a ^ n) • (hI.dpow n x) :=
by simp only [smul_eq_mul, hI.dpow_smul, hx]

lemma factorial_mul_dpow_eq_pow (n : ℕ) (x : A) (hx : x ∈ I) :
  (n.factorial : A) * (hI.dpow n x) = x^n :=
begin
  induction n with n ih,
  { rw [nat.nat_zero_eq_zero, nat.factorial_zero, nat.cast_one, one_mul, pow_zero,
      hI.dpow_zero hx], },
  { rw [nat.factorial_succ, mul_comm (n + 1), ← (n + 1).choose_one_right,
  ← nat.choose_symm_add, nat.cast_mul, nat.succ_eq_add_one, mul_assoc,
  ← hI.dpow_mul n 1 hx, ← mul_assoc, ih, hI.dpow_one hx, pow_succ'], }
end

lemma dpow_eval_zero {n : ℕ} (hn : n ≠ 0) : hI.dpow n 0 = 0 :=
by rw [← mul_zero (0 : A), hI.dpow_smul n I.zero_mem, zero_pow' n hn, zero_mul, zero_mul]

/-- Proposition 1.2.7 of [B74], part (i). -/
lemma nilpotent_of_pd_ideal_mem (hI : divided_powers I) {n : ℕ} (hn : n ≠ 0)
  (hnI : ∀ {y : A}(hy : y ∈ I), n • y = 0) {x : A} (hx : x ∈ I) : x^n = 0 :=
begin
  have h_fac: (n.factorial : A) * hI.dpow n x = n • ((n-1).factorial : A) * hI.dpow n x,
  { rw [nsmul_eq_mul, ← nat.cast_mul, nat.mul_factorial_pred (nat.pos_of_ne_zero hn)] },
  rw [← factorial_mul_dpow_eq_pow hI _ _ hx, h_fac, smul_mul_assoc],
  exact hnI (I.mul_mem_left ((n - 1).factorial : A) (hI.dpow_mem hn hx))
end

/-- If J is another ideal of A with divided powers,
then the divided powers of I and J coincide on I • J
(Berthelot, 1.6.1 (ii))-/
lemma coincide_on_smul {J : ideal A} (hJ : divided_powers J) {n : ℕ} {a : A} (ha : a ∈ I • J) :
  hI.dpow n a = hJ.dpow n a :=
begin
  revert n,
  apply submodule.smul_induction_on' ha,
  { intros a ha b hb n,
    rw [algebra.id.smul_eq_mul, hJ.dpow_smul n hb, mul_comm a b, hI.dpow_smul n ha,
      ← hJ.factorial_mul_dpow_eq_pow n b hb, ← hI.factorial_mul_dpow_eq_pow n a ha],
    ring, },
  { intros x hx y hy hx' hy' n,
    rw [hI.dpow_add n (ideal.mul_le_right hx) (ideal.mul_le_right hy),
      hJ.dpow_add n (ideal.mul_le_left hx) (ideal.mul_le_left hy)],
    apply finset.sum_congr rfl,
    intros k hk,
    rw [hx', hy'], },
end

open finset

/- Rob65, formula (III')-/
/-- A product of divided powers is a multinomial coefficient times the divided power-/
lemma mul_dpow {ι : Type*} [decidable_eq ι] {s : finset ι} (n : ι → ℕ) {a : A} (ha : a ∈ I):
  s.prod (λ i, hI.dpow (n i) a) = (nat.multinomial s n) * hI.dpow (s.sum n) a :=
begin
  revert s,
  apply finset.induction,
  -- case : s = ∅
  simp only [prod_empty, nat.multinomial_nil, algebra_map.coe_one, sum_empty, one_mul, hI.dpow_zero ha],
  -- inductive step
  intros i s hi hrec,
  rw finset.prod_insert hi, rw hrec,
  rw ←mul_assoc,
  nth_rewrite 1 [mul_comm],
  rw mul_assoc,
  rw dpow_mul _ _ _ ha,
  rw ← finset.sum_insert hi,
  rw ← mul_assoc,
  apply congr_arg2 _ _ rfl,
  rw [nat.multinomial_insert _ _ hi, mul_comm, nat.cast_mul, finset.sum_insert hi],
end

-- Also : can it be used to deduce dpow_comp from the rest?
/-- A generic “multinomial” theorem for divided powers — but without multinomial coefficients
  — using only dpow_zero, dpow_add and dpow_eval_zero  -/
lemma sum_dpow_aux (dpow : ℕ → A → A) (dpow_zero : ∀ {x} (hx : x ∈ I), dpow 0 x = 1)
  (dpow_add : ∀ n {x y} (hx : x ∈ I) (hy : y ∈ I) , dpow n (x + y) =
    finset.sum (finset.range (n + 1)) (λ k, (dpow k x) * (dpow (n - k) y)))
  (dpow_eval_zero : ∀ {n : ℕ} (hn : n ≠ 0), dpow n 0 = 0) {ι : Type*} [decidable_eq ι]
  {s : finset ι} {x : ι → A} (hx : ∀ i ∈ s, x i ∈ I) :
  ∀ (n : ℕ), dpow n (s.sum x) =
    (finset.sym s n).sum (λ k, s.prod (λ i, dpow (multiset.count i k) (x i))) :=
begin
  induction s using finset.induction with a s ha ih,
  { rw sum_empty,
    rintro (_ | n),
    { rw [dpow_zero (I.zero_mem), sum_unique_nonempty, prod_empty],
      exact univ_nonempty },
    { rw [dpow_eval_zero (nat.succ_ne_zero n), sym_empty, sum_empty], }},
  { have hx' : ∀ i, i ∈ s → x i ∈ I :=
    λ i hi, hx i (finset.mem_insert_of_mem hi),
    intro n,
    simp_rw [sum_insert ha,
      dpow_add n (hx a (finset.mem_insert_self a s))
        (I.sum_mem (λ i, hx' i)),
      sum_range, ih hx', mul_sum, sum_sigma'],

    refine (sum_bij'
      (λ m _, sym.filter_ne a m)
      (λ m hm, finset.mem_sigma.2 ⟨mem_univ _, _⟩)
      (λ m hm, _)
      (λ m _, m.2.fill a m.1)
      _
      (λ m _, m.fill_filter_ne a)
      -- explicit arguments above rather than m.fill_filter_ne a
      -- adjust once multinomial has been incorporated to mathlib
      (λ m hm, _)).symm,

  -- #3
    { convert sym_filter_ne_mem a hm, rw erase_insert ha },
  -- #4
    { dsimp only [sym.filter_ne, fin.coe_mk],
      rw finset.prod_insert ha,
      apply congr_arg2 _ rfl,
      apply finset.prod_congr rfl,
      intros i hi, simp only [subtype.val_eq_coe, sym.mk_coe],
      apply congr_arg2 _ _ rfl,
      rw multiset.count_filter,
      rw if_pos _,
      intro hi', apply ha, rw hi', exact hi, },

    { exact λ m hm, sym_fill_mem a (mem_sigma.1 hm).2 },
    { exact sym.filter_ne_fill a m (mt (mem_sym_iff.1 (mem_sigma.1 hm).2 a) ha) }},
end

/-- A “multinomial” theorem for divided powers — without multinomial coefficients -/
lemma sum_dpow {ι : Type*} [decidable_eq ι] {s : finset ι} {x : ι → A} (hx : ∀ i ∈ s, x i ∈ I) :
  ∀ (n : ℕ), hI.dpow n (s.sum x) =
    (finset.sym s n).sum (λ k, s.prod (λ i, hI.dpow (multiset.count i k) (x i))) :=
sum_dpow_aux hI.dpow (λ x hx, hI.dpow_zero hx)
  (λ n x y hx hy, hI.dpow_add n hx hy) (λ n hn, hI.dpow_eval_zero hn) hx

lemma prod_dpow_self {ι : Type*} [decidable_eq ι] {s : finset ι} {n : ι → ℕ} (a : A) (ha : a ∈ I) :
  s.prod (λ i, hI.dpow (n i) a) = nat.multinomial s n * hI.dpow (s.sum n) a :=
begin
  induction s using finset.induction with i s hi ih,
  { rw [finset.prod_empty, finset.sum_empty, hI.dpow_zero ha, nat.multinomial_nil,
      nat.cast_one, mul_one] },
  { rw [finset.prod_insert hi, ih, ← mul_assoc, mul_comm (hI.dpow _ a), mul_assoc,
      hI.dpow_mul _ _ ha, ← finset.sum_insert hi, ← mul_assoc],
    apply congr_arg2 _ _ rfl,
    rw [mul_comm, nat.multinomial_insert s n hi, finset.sum_insert hi, nat.cast_mul], },
end

end basic_lemmas

section divided_powers_morphisms

/-- Compatibility of a ring morphism with pd-structures -/
def is_pd_morphism {A B : Type*} [comm_ring A] [comm_ring B] {I : ideal A} {J : ideal B}
  (hI : divided_powers I) (hJ : divided_powers J) (f : A →+* B) : Prop :=
(I.map f) ≤ J ∧  ∀ (n : ℕ) (a ∈ I), hJ.dpow n (f a) = f (hI.dpow n a)

/-- The structure of a pd_morphism between rings endowed with pd-rings -/
structure pd_morphism {A B : Type*} [comm_ring A] [comm_ring B] {I : ideal A} {J : ideal B }
  (hI : divided_powers I) (hJ : divided_powers J) :=
(to_ring_hom : A →+* B)
(ideal_comp : I.map to_ring_hom ≤ J)
(dpow_comp : ∀ (n : ℕ) (a ∈ I),
  hJ.dpow n (to_ring_hom a) = to_ring_hom (hI.dpow n a))

/- Roby65, Proposition 2. (TODO: rename?)-/
def pd_morphism_ideal {A B : Type*} [comm_ring A] [comm_ring B] {I : ideal A} {J : ideal B}
  (hI : divided_powers I) (hJ : divided_powers J) {f : A →+* B} (hf : I.map f ≤ J) :
  ideal A :=
{ carrier   := {x ∈ I | ∀ (n : ℕ), f (hI.dpow n (x : A)) = (hJ.dpow n (f (x : A)))},
  add_mem'  := λ x y hx hy,
  begin
    simp only [set.mem_sep_iff, set_like.mem_coe] at hx hy ⊢,
    refine ⟨I.add_mem hx.1 hy.1, _⟩,
    intros n,
    rw [hI.dpow_add _ hx.1 hy.1, map_add,
      hJ.dpow_add _ (hf ( ideal.mem_map_of_mem f hx.1)) (hf ( ideal.mem_map_of_mem f hy.1)),
      map_sum],
    apply congr_arg,
    ext k,
    rw [map_mul, hx.2 k, hy.2 (n - k)]
  end,
  zero_mem' := begin
    simp only [set.mem_sep_iff, set_like.mem_coe, submodule.zero_mem, map_zero, true_and],
    intro n,
    cases n,
    { rw [hI.dpow_zero I.zero_mem, hJ.dpow_zero J.zero_mem, map_one] },
    { rw [hI.dpow_eval_zero n.succ_ne_zero,hJ.dpow_eval_zero n.succ_ne_zero, map_zero] }
  end,
  smul_mem' := λ r x hx,
  begin
    simp only [set.mem_sep_iff, set_like.mem_coe] at hx ⊢,
    refine ⟨I.smul_mem r hx.1, _⟩,
    intros n,
    rw [smul_eq_mul, hI.dpow_smul _ hx.1, map_mul, map_mul, map_pow,
      hJ.dpow_smul _ (hf ( ideal.mem_map_of_mem f hx.1)), hx.2 n],
  end }

/- Roby65, Proposition 3.  (TODO: rename?) -/
def pd_morphism_from_gens {A B : Type*} [comm_ring A] [comm_ring B] {I : ideal A} {J : ideal B}
  (hI : divided_powers I) (hJ : divided_powers J) {f : A →+* B} {S : set A} (hS : ideal.span S = I)
  (hf : I.map f ≤ J) (h : ∀ (x : S) (n : ℕ), f (hI.dpow n x) = hJ.dpow n (f x)) :
  pd_morphism hI hJ :=
{ to_ring_hom := f,
  ideal_comp  := hf,
  dpow_comp   := λ n x hx,
  begin
    have hS' : S ⊆ (pd_morphism_ideal hI hJ hf),
    { intros y hy,
      simp only [set_like.mem_coe, pd_morphism_ideal, submodule.mem_mk, set.mem_sep_iff,
        set_like.mem_coe],
      split,
      rw ←hS,
      exact ideal.subset_span hy,
      exact h ⟨y, hy⟩ },
    rw [← ideal.span_le, hS] at hS',
    exact ((hS' hx).2 n).symm,
  end }

lemma pd_morphism_from_gens_coe {A B : Type*} [comm_ring A] [comm_ring B] {I : ideal A} {J : ideal B}
  (hI : divided_powers I) (hJ : divided_powers J) {f : A →+* B} {S : set A} (hS : ideal.span S = I)
  (hf : I.map f ≤ J) (h : ∀ (x : S) (n : ℕ), f (hI.dpow n x) = hJ.dpow n (f x)) :
  (pd_morphism_from_gens hI hJ hS hf h).to_ring_hom = f :=
rfl

/- Roby65, corollary after proposition 3 -/
example {A : Type*} [comm_ring A] {I : ideal A} (hI hI' : divided_powers I) {S : set A} (hS : ideal.span S = I) (hdp : ∀ (n : ℕ) (a ∈ S), hI.dpow n a = hI'.dpow n a) : hI = hI' :=
begin
  suffices : I.map (ring_hom.id A) ≤ I,
  let pd_id := pd_morphism_from_gens hI hI' hS this _,
  ext n a,
  by_cases ha : a ∈ I,
  have := pd_id.dpow_comp n a ha,
  suffices pd_id_id : ∀ (x : A), pd_id.to_ring_hom x = x,
  simp only [pd_id_id] at this,  exact this.symm,
  { intro x,refl, },
  sorry,
  sorry,
  sorry,
end

-- For the moment, the notation does not work
-- notation `p(` A `,` I, `,` hI `)` →ₚ  `(` B `,` J, `,` hJ `)` := pd_morphism hI hJ
-- Also, we expect a `pd` subscript

/- TODO : identity, composition… -/

end divided_powers_morphisms

end divided_powers

/- Comparison with Berthelot, Coho. cristalline

1.1 : done
1.2.1 : follows from 1.2.7 - done (for ℚ-algebras).
1.2.2 (*) : To be added
1.2.4 : To be added if Cohen/Witt vectors rings exist
1.2.7 (M) : done
1.3 (pd -morphism) : done
1.3.1 : To be added (needs colimits of rings)

1.4 : To be added, but difficult
1.5.: depends on 1.4

1.6 : sub-pd-ideal : done
1.6.1 Done !
1.6.2 : Done : dpow_quot]
1.6.4 (A) : to be added
(should we add the remark on page 33)
1.6.5 (A): to be added

1.7 : tensor product, see Roby

1.8 (M). Done!

PRs :
 (M) : ring_inverse, tsub_tsub - DONE
 (A) : submodule_induction, function.extend_apply_first - DONE

Delete obsolete versions
 (A) : rewrite_4_sums -- Done, I think, but how could we simplify these lemmas?

(A) Simplify,
  remove not_eq_or_aux (see REMOVE or MOVE) -- DONE
  Prove uniqueness of pd-structure when possible
    (ideal_add [Done], dpow_quot [Done])
(M) Complete the lattice structure

-/

example (M : Type*) [add_monoid M] : add_monoid (with_top M) := by refine with_top.add_monoid

/- Roby (1965):
 - Pregraded algebra (using mathlib's graded_algebra) - with_top unit (later, if needed)
 - Tensor product of graded algebras is a graded algebra
 - Add III' explicitly.
 - Proposition 1 -- I think this is essentially Lemma 3.6 of [BO].
 - Proposition 2
 - Proposition 3

 I just noticed that we are using dp and pd in different names, we should pick a convention.
-/

/-
Idea of generalizing the theory to more general divisors systems
modeling x^n/n!, x^n/p^n, etc.
but it is not clear what to consider
Also, not clear it can really be done…

structure divisor_system {R : Type*} [comm_ring R] :=
(dpow_choose : ℕ → ℕ → R)
(dpow_mchoose : ℕ → ℕ → R)
-- (conditions : Prop)
Two options :
1) dpow n x = x^n/(c n)
Examples : c n = n.factorial,  c n = p ^ n
2) dpow n x = x ^ n / (d 1 * d 2 * ... * d n)
Examples : d n = n,  d n = p

dpow n (x + y) = (x+y)^n / c n
 = sum  (n.choose k) x ^(n -k) y ^k / c n
 = sum [(n.choose k) (c k) (c (n-k)) / c n] dpow (n - k) x * dpow k y

  Case 1 : dpow_choose n k = 1 ;  case 2 : dpow_choose n k = choose

dpow m x * dpow n x = x ^ m * x ^ n / c m * c n
  = dpow (m + n) x * (c (n+m) / c m * c n)

   Case 1 : coeff = (n+m).choose m ; Case 2 :  = 1

dpow m (dpow n x) = (x ^n / c n) ^ m / c m = x ^ (m n) / ((c n ^ m) * c m)
 = [ ] * dpow (m n) x
  with [ ] = c (m n)/ (c n)^m (c m)

  Case 1 : [ ] = mchoose m n, case 2 : p^ (-m)

-/


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.instances.real_vector_space
import Mathlib.analysis.normed_space.add_torsor
import Mathlib.linear_algebra.affine_space.midpoint
import Mathlib.analysis.normed_space.linear_isometry
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Mazur-Ulam Theorem

Mazur-Ulam theorem states that an isometric bijection between two normed affine spaces over `ℝ` is
affine. We formalize it in three definitions:

* `isometric.to_real_linear_isometry_equiv_of_map_zero` : given `E ≃ᵢ F` sending `0` to `0`,
  returns `E ≃ₗᵢ[ℝ] F` with the same `to_fun` and `inv_fun`;
* `isometric.to_real_linear_isometry_equiv` : given `f : E ≃ᵢ F`,
  returns `g : E ≃ₗᵢ[ℝ] F` with `g x = f x - f 0`.
* `isometric.to_affine_equiv` : given `PE ≃ᵢ PF`, returns `g : PE ≃ᵃ[ℝ] PF` with the same
  `to_equiv`.

The formalization is based on [Jussi Väisälä, *A Proof of the Mazur-Ulam Theorem*][Vaisala_2003].

## Tags

isometry, affine map, linear map
-/

namespace isometric

/-- If an isometric self-homeomorphism of a normed vector space over `ℝ` fixes `x` and `y`,
then it fixes the midpoint of `[x, y]`. This is a lemma for a more general Mazur-Ulam theorem,
see below. -/
theorem midpoint_fixed {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E]
    [metric_space PE] [normed_add_torsor E PE] {x : PE} {y : PE} (e : PE ≃ᵢ PE) :
    coe_fn e x = x → coe_fn e y = y → coe_fn e (midpoint ℝ x y) = midpoint ℝ x y :=
  sorry

/-- A bijective isometry sends midpoints to midpoints. -/
theorem map_midpoint {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E]
    [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4} [normed_group F]
    [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) (x : PE) (y : PE) :
    coe_fn f (midpoint ℝ x y) = midpoint ℝ (coe_fn f x) (coe_fn f y) :=
  sorry

/-!
Since `f : PE ≃ᵢ PF` sends midpoints to midpoints, it is an affine map.
We define a conversion to a `continuous_linear_equiv` first, then a conversion to an `affine_map`.
-/

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ` and `f 0 = 0`, then `f` is a linear equivalence. -/
def to_real_linear_isometry_equiv_of_map_zero {E : Type u_1} [normed_group E] [normed_space ℝ E]
    {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (h0 : coe_fn f 0 = 0) :
    linear_isometry_equiv ℝ E F :=
  linear_isometry_equiv.mk
    (linear_equiv.mk
      (linear_map.to_fun
        (continuous_linear_map.to_linear_map
          (add_monoid_hom.to_real_linear_map (add_monoid_hom.of_map_midpoint ℝ ℝ (⇑f) h0 sorry)
            sorry)))
      sorry sorry (equiv.inv_fun (to_equiv f)) sorry sorry)
    sorry

@[simp] theorem coe_to_real_linear_equiv_of_map_zero {E : Type u_1} [normed_group E]
    [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F)
    (h0 : coe_fn f 0 = 0) : ⇑(to_real_linear_isometry_equiv_of_map_zero f h0) = ⇑f :=
  rfl

@[simp] theorem coe_to_real_linear_equiv_of_map_zero_symm {E : Type u_1} [normed_group E]
    [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F)
    (h0 : coe_fn f 0 = 0) :
    ⇑(linear_isometry_equiv.symm (to_real_linear_isometry_equiv_of_map_zero f h0)) =
        ⇑(isometric.symm f) :=
  rfl

/-- Mazur-Ulam Theorem: if `f` is an isometric bijection between two normed vector spaces
over `ℝ`, then `x ↦ f x - f 0` is a linear equivalence. -/
def to_real_linear_isometry_equiv {E : Type u_1} [normed_group E] [normed_space ℝ E] {F : Type u_3}
    [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) : linear_isometry_equiv ℝ E F :=
  to_real_linear_isometry_equiv_of_map_zero
    (isometric.trans f (isometric.symm (isometric.add_right (coe_fn f 0)))) sorry

@[simp] theorem to_real_linear_equiv_apply {E : Type u_1} [normed_group E] [normed_space ℝ E]
    {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (x : E) :
    coe_fn (to_real_linear_isometry_equiv f) x = coe_fn f x - coe_fn f 0 :=
  Eq.symm (sub_eq_add_neg (coe_fn f x) (coe_fn f 0))

@[simp] theorem to_real_linear_isometry_equiv_symm_apply {E : Type u_1} [normed_group E]
    [normed_space ℝ E] {F : Type u_3} [normed_group F] [normed_space ℝ F] (f : E ≃ᵢ F) (y : F) :
    coe_fn (linear_isometry_equiv.symm (to_real_linear_isometry_equiv f)) y =
        coe_fn (isometric.symm f) (y + coe_fn f 0) :=
  rfl

/-- Convert an isometric equivalence between two affine spaces to an `affine_map`. -/
def to_affine_equiv {E : Type u_1} {PE : Type u_2} [normed_group E] [normed_space ℝ E]
    [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4} [normed_group F]
    [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) :
    affine_equiv ℝ PE PF :=
  affine_equiv.mk' (to_equiv f)
    (linear_isometry_equiv.to_linear_equiv
      (to_real_linear_isometry_equiv
        (isometric.trans (vadd_const (classical.arbitrary PE))
          (isometric.trans f (isometric.symm (vadd_const (coe_fn f (classical.arbitrary PE))))))))
    (classical.arbitrary PE) sorry

@[simp] theorem coe_to_affine_equiv {E : Type u_1} {PE : Type u_2} [normed_group E]
    [normed_space ℝ E] [metric_space PE] [normed_add_torsor E PE] {F : Type u_3} {PF : Type u_4}
    [normed_group F] [normed_space ℝ F] [metric_space PF] [normed_add_torsor F PF] (f : PE ≃ᵢ PF) :
    ⇑(to_affine_equiv f) = ⇑f :=
  rfl

end Mathlib


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.punit
import Mathlib.category_theory.comma
import Mathlib.category_theory.is_connected
import Mathlib.category_theory.limits.yoneda
import Mathlib.category_theory.limits.types
import Mathlib.PostPort

universes v u

namespace Mathlib

/-!
# Cofinal functors

A functor `F : C ⥤ D` is cofinal if for every `d : D`,
the comma category of morphisms `d ⟶ F.obj c` is connected.

We prove the following three statements are equivalent:
1. `F : C ⥤ D` is cofinal.
2. Every functor `G : D ⥤ E` has a colimit if and only if `F ⋙ G` does,
   and these colimits are isomorphic via `colimit.pre G F`.
3. `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`.

Starting at 1. we show (in `cocones_equiv`) that
the categories of cocones over `G : D ⥤ E` and over `F ⋙ G` are equivalent.
(In fact, via an equivalence which does not change the cocone point.)
This readily implies 2., as `comp_has_colimit`, `has_colimit_of_comp`, and `colimit_iso`.

From 2. we can specialize to `G = coyoneda.obj (op d)` to obtain 3., as `colimit_comp_coyoneda_iso`.

From 3., we prove 1. directly in `cofinal_of_colimit_comp_coyoneda_iso_punit`.

We also show these conditions imply:
4. Every functor `H : Dᵒᵖ ⥤ E` has a limit if and only if `F.op ⋙ H` does,
   and these limits are isomorphic via `limit.pre H F.op`.

## Naming
There is some discrepancy in the literature about naming; some say 'final' instead of 'cofinal'.
The explanation for this is that the 'co' prefix here is *not* the usual category-theoretic one
indicating duality, but rather indicating the sense of "along with".

While the trend seems to be towards using 'final', for now we go with the bulk of the literature
and use 'cofinal'.

## References
* https://stacks.math.columbia.edu/tag/09WN
* https://ncatlab.org/nlab/show/final+functor
* Borceux, Handbook of Categorical Algebra I, Section 2.11.
  (Note he reverses the roles of definition and main result relative to here!)
-/

namespace category_theory

/--
A functor `F : C ⥤ D` is cofinal if for every `d : D`, the comma category of morphisms `d ⟶ F.obj c`
is connected.

See https://stacks.math.columbia.edu/tag/04E6
-/
def cofinal {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) :=
  ∀ (d : D), is_connected (comma (functor.from_punit d) F)

protected instance comma.is_connected {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [ℱ : cofinal F] (d : D) : is_connected (comma (functor.from_punit d) F) :=
  ℱ d

namespace cofinal

protected instance category_theory.comma.nonempty {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] (d : D) : Nonempty (comma (functor.from_punit d) F) :=
  is_connected.is_nonempty

/--
When `F : C ⥤ D` is cofinal, we denote by `lift F d` an arbitrary choice of object in `C` such that
there exists a morphism `d ⟶ F.obj (lift F d)`.
-/
def lift {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] (d : D) : C :=
  comma.right (classical.arbitrary (comma (functor.from_punit d) F))

/--
When `F : C ⥤ D` is cofinal, we denote by `hom_to_lift` an arbitrary choice of morphism
`d ⟶ F.obj (lift F d)`.
-/
def hom_to_lift {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] (d : D) : d ⟶ functor.obj F (lift F d) :=
  comma.hom (classical.arbitrary (comma (functor.from_punit d) F))

/--
We provide an induction principle for reasoning about `lift` and `hom_to_lift`.
We want to perform some construction (usually just a proof) about
the particular choices `lift F d` and `hom_to_lift F d`,
it suffices to perform that construction for some other pair of choices
(denoted `X₀ : C` and `k₀ : d ⟶ F.obj X₀` below),
and to show that how to transport such a construction
*both* directions along a morphism between such choices.
-/
theorem induction {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {d : D} (Z : (X : C) → (d ⟶ functor.obj F X) → Prop) (h₁ : ∀ (X₁ X₂ : C) (k₁ : d ⟶ functor.obj F X₁) (k₂ : d ⟶ functor.obj F X₂) (f : X₁ ⟶ X₂),
  k₁ ≫ functor.map F f = k₂ → Z X₁ k₁ → Z X₂ k₂) (h₂ : ∀ (X₁ X₂ : C) (k₁ : d ⟶ functor.obj F X₁) (k₂ : d ⟶ functor.obj F X₂) (f : X₁ ⟶ X₂),
  k₁ ≫ functor.map F f = k₂ → Z X₂ k₂ → Z X₁ k₁) {X₀ : C} {k₀ : d ⟶ functor.obj F X₀} (z : Z X₀ k₀) : Z (lift F d) (hom_to_lift F d) := sorry

/--
Given a cocone over `F ⋙ G`, we can construct a `cocone G` with the same cocone point.
-/
@[simp] theorem extend_cocone_map_hom {C : Type v} [small_category C] {D : Type v} [small_category D] {F : C ⥤ D} [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (X : limits.cocone (F ⋙ G)) (Y : limits.cocone (F ⋙ G)) (f : X ⟶ Y) : limits.cocone_morphism.hom (functor.map extend_cocone f) = limits.cocone_morphism.hom f :=
  Eq.refl (limits.cocone_morphism.hom (functor.map extend_cocone f))

@[simp] theorem colimit_cocone_comp_aux {C : Type v} [small_category C] {D : Type v} [small_category D] {F : C ⥤ D} [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (s : limits.cocone (F ⋙ G)) (j : C) : functor.map G (hom_to_lift F (functor.obj F j)) ≫ nat_trans.app (limits.cocone.ι s) (lift F (functor.obj F j)) =
  nat_trans.app (limits.cocone.ι s) j := sorry

/-- An auxilliary construction for `extend_cone`, moving `op` around. -/
def extend_cone_cone_to_cocone {C : Type v} [small_category C] {D : Type v} [small_category D] {E : Type u} [category E] {F : C ⥤ D} {H : Dᵒᵖ ⥤ E} (c : limits.cone (functor.op F ⋙ H)) : limits.cocone (F ⋙ functor.right_op H) :=
  limits.cocone.mk (opposite.op (limits.cone.X c))
    (nat_trans.mk fun (j : C) => has_hom.hom.op (nat_trans.app (limits.cone.π c) (opposite.op j)))

/-- An auxilliary construction for `extend_cone`, moving `op` around. -/
def extend_cone_cocone_to_cone {D : Type v} [small_category D] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (c : limits.cocone (functor.right_op H)) : limits.cone H :=
  limits.cone.mk (opposite.unop (limits.cocone.X c))
    (nat_trans.mk fun (j : Dᵒᵖ) => has_hom.hom.unop (nat_trans.app (limits.cocone.ι c) (opposite.unop j)))

/--
Given a cone over `F.op ⋙ H`, we can construct a `cone H` with the same cone point.
-/
@[simp] theorem extend_cone_map_hom {C : Type v} [small_category C] {D : Type v} [small_category D] {F : C ⥤ D} [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (X : limits.cone (functor.op F ⋙ H)) (Y : limits.cone (functor.op F ⋙ H)) (f : X ⟶ Y) : limits.cone_morphism.hom (functor.map extend_cone f) = limits.cone_morphism.hom f :=
  Eq.refl (limits.cone_morphism.hom (functor.map extend_cone f))

@[simp] theorem limit_cone_comp_aux {C : Type v} [small_category C] {D : Type v} [small_category D] {F : C ⥤ D} [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (s : limits.cone (functor.op F ⋙ H)) (j : Cᵒᵖ) : nat_trans.app (limits.cone.π s) (opposite.op (lift F (functor.obj F (opposite.unop j)))) ≫
    functor.map H (has_hom.hom.op (hom_to_lift F (functor.obj F (opposite.unop j)))) =
  nat_trans.app (limits.cone.π s) j :=
  has_hom.hom.op_inj (colimit_cocone_comp_aux (extend_cone_cone_to_cocone s) (opposite.unop j))

/--
If `F` is cofinal,
the category of cocones on `F ⋙ G` is equivalent to the category of cocones on `G`,
for any `G : D ⥤ E`.
-/
@[simp] theorem cocones_equiv_unit_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] (G : D ⥤ E) : equivalence.unit_iso (cocones_equiv F G) =
  nat_iso.of_components
    (fun (c : limits.cocone (F ⋙ G)) =>
      limits.cocones.ext (iso.refl (limits.cocone.X (functor.obj 𝟭 c))) (cocones_equiv._proof_1 F G c))
    (cocones_equiv._proof_2 F G) :=
  Eq.refl (equivalence.unit_iso (cocones_equiv F G))

/--
If `F` is cofinal,
the category of cones on `F.op ⋙ H` is equivalent to the category of cones on `H`,
for any `H : Dᵒᵖ ⥤ E`.
-/
@[simp] theorem cones_equiv_counit_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] (H : Dᵒᵖ ⥤ E) : equivalence.counit_iso (cones_equiv F H) =
  nat_iso.of_components
    (fun (c : limits.cone H) =>
      limits.cones.ext (iso.refl (limits.cone.X (functor.obj (limits.cones.whiskering (functor.op F) ⋙ extend_cone) c)))
        (cones_equiv._proof_3 F H c))
    (cones_equiv._proof_4 F H) :=
  Eq.refl (equivalence.counit_iso (cones_equiv F H))

-- We could have done this purely formally in terms of `cocones_equiv`,

-- without having defined `extend_cone` at all,

-- but it comes at the cost of moving a *lot* of opposites around:

-- (((cones.functoriality_equivalence _ (op_op_equivalence E)).symm.trans

--   ((((cocone_equivalence_op_cone_op _).symm.trans

--     (cocones_equiv F (unop_unop _ ⋙ H.op))).trans

--     (cocone_equivalence_op_cone_op _)).unop)).trans

--   (cones.functoriality_equivalence _ (op_op_equivalence E))).trans

--   (cones.postcompose_equivalence (nat_iso.of_components (λ X, iso.refl _) (by tidy) :

--     H ≅ (unop_unop D ⋙ H.op).op ⋙ (op_op_equivalence E).functor)).symm

/--
When `F : C ⥤ D` is cofinal, and `t : cocone G` for some `G : D ⥤ E`,
`t.whisker F` is a colimit cocone exactly when `t` is.
-/
def is_colimit_whisker_equiv {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (t : limits.cocone G) : limits.is_colimit (limits.cocone.whisker F t) ≃ limits.is_colimit t :=
  limits.is_colimit.of_cocone_equiv (equivalence.symm (cocones_equiv F G))

/--
When `F : C ⥤ D` is cofinal, and `t : cone H` for some `H : Dᵒᵖ ⥤ E`,
`t.whisker F.op` is a limit cone exactly when `t` is.
-/
def is_limit_whisker_equiv {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (t : limits.cone H) : limits.is_limit (limits.cone.whisker (functor.op F) t) ≃ limits.is_limit t :=
  limits.is_limit.of_cone_equiv (equivalence.symm (cones_equiv F H))

/--
When `F` is cofinal, and `t : cocone (F ⋙ G)`,
`extend_cocone.obj t` is a colimit coconne exactly when `t` is.
-/
def is_colimit_extend_cocone_equiv {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (t : limits.cocone (F ⋙ G)) : limits.is_colimit (functor.obj extend_cocone t) ≃ limits.is_colimit t :=
  limits.is_colimit.of_cocone_equiv (cocones_equiv F G)

/--
When `F` is cofinal, and `t : cone (F.op ⋙ H)`,
`extend_cone.obj t` is a limit conne exactly when `t` is.
-/
def is_limit_extend_cone_equiv {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (t : limits.cone (functor.op F ⋙ H)) : limits.is_limit (functor.obj extend_cone t) ≃ limits.is_limit t :=
  limits.is_limit.of_cone_equiv (cones_equiv F H)

/-- Given a colimit cocone over `G : D ⥤ E` we can construct a colimit cocone over `F ⋙ G`. -/
@[simp] theorem colimit_cocone_comp_cocone {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (t : limits.colimit_cocone G) : limits.colimit_cocone.cocone (colimit_cocone_comp F t) = limits.cocone.whisker F (limits.colimit_cocone.cocone t) :=
  Eq.refl (limits.colimit_cocone.cocone (colimit_cocone_comp F t))

/-- Given a limit cone over `H : Dᵒᵖ ⥤ E` we can construct a limit cone over `F.op ⋙ H`. -/
@[simp] theorem limit_cone_comp_cone {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (t : limits.limit_cone H) : limits.limit_cone.cone (limit_cone_comp F t) = limits.cone.whisker (functor.op F) (limits.limit_cone.cone t) :=
  Eq.refl (limits.limit_cone.cone (limit_cone_comp F t))

protected instance comp_has_colimit {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} [limits.has_colimit G] : limits.has_colimit (F ⋙ G) :=
  limits.has_colimit.mk (colimit_cocone_comp F (limits.get_colimit_cocone G))

protected instance comp_has_limit {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} [limits.has_limit H] : limits.has_limit (functor.op F ⋙ H) :=
  limits.has_limit.mk (limit_cone_comp F (limits.get_limit_cone H))

theorem colimit_pre_is_iso_aux {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} {t : limits.cocone G} (P : limits.is_colimit t) : limits.is_colimit.desc (coe_fn (equiv.symm (is_colimit_whisker_equiv F t)) P) (limits.cocone.whisker F t) = 𝟙 := sorry

protected instance colimit_pre_is_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} [limits.has_colimit G] : is_iso (limits.colimit.pre G F) :=
  eq.mpr sorry (eq.mpr sorry (id is_iso.comp_is_iso))

theorem limit_pre_is_iso_aux {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} {t : limits.cone H} (P : limits.is_limit t) : limits.is_limit.lift (coe_fn (equiv.symm (is_limit_whisker_equiv F t)) P) (limits.cone.whisker (functor.op F) t) = 𝟙 := sorry

protected instance limit_pre_is_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} [limits.has_limit H] : is_iso (limits.limit.pre H (functor.op F)) :=
  eq.mpr sorry (eq.mpr sorry (id is_iso.comp_is_iso))

/--
When `F : C ⥤ D` is cofinal, and `G : D ⥤ E` has a colimit, then `F ⋙ G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] (G : D ⥤ E) [limits.has_colimit G] : limits.colimit (F ⋙ G) ≅ limits.colimit G :=
  as_iso (limits.colimit.pre G F)

/--
When `F : C ⥤ D` is cofinal, and `H : Dᵒᵖ ⥤ E` has a limit, then `F.op ⋙ H` has a limit also and
`limit (F.op ⋙ H) ≅ limit H`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] (H : Dᵒᵖ ⥤ E) [limits.has_limit H] : limits.limit (functor.op F ⋙ H) ≅ limits.limit H :=
  iso.symm (as_iso (limits.limit.pre H (functor.op F)))

/-- Given a colimit cocone over `F ⋙ G` we can construct a colimit cocone over `G`. -/
@[simp] theorem colimit_cocone_of_comp_is_colimit {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} (t : limits.colimit_cocone (F ⋙ G)) : limits.colimit_cocone.is_colimit (colimit_cocone_of_comp F t) =
  coe_fn (equiv.symm (is_colimit_extend_cocone_equiv F (limits.colimit_cocone.cocone t)))
    (limits.colimit_cocone.is_colimit t) :=
  Eq.refl (limits.colimit_cocone.is_colimit (colimit_cocone_of_comp F t))

/-- Given a limit cone over `F.op ⋙ H` we can construct a limit cone over `H`. -/
@[simp] theorem limit_cone_of_comp_is_limit {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} (t : limits.limit_cone (functor.op F ⋙ H)) : limits.limit_cone.is_limit (limit_cone_of_comp F t) =
  coe_fn (equiv.symm (is_limit_extend_cone_equiv F (limits.limit_cone.cone t))) (limits.limit_cone.is_limit t) :=
  Eq.refl (limits.limit_cone.is_limit (limit_cone_of_comp F t))

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_colimit`.)
-/
theorem has_colimit_of_comp {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} [limits.has_colimit (F ⋙ G)] : limits.has_colimit G :=
  limits.has_colimit.mk (colimit_cocone_of_comp F (limits.get_colimit_cocone (F ⋙ G)))

/--
When `F` is cofinal, and `F.op ⋙ H` has a limit, then `H` has a limit also.

We can't make this an instance, because `F` is not determined by the goal.
(Even if this weren't a problem, it would cause a loop with `comp_has_limit`.)
-/
theorem has_limit_of_comp {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} [limits.has_limit (functor.op F ⋙ H)] : limits.has_limit H :=
  limits.has_limit.mk (limit_cone_of_comp F (limits.get_limit_cone (functor.op F ⋙ H)))

/--
When `F` is cofinal, and `F ⋙ G` has a colimit, then `G` has a colimit also and
`colimit (F ⋙ G) ≅ colimit G`

https://stacks.math.columbia.edu/tag/04E7
-/
def colimit_iso' {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {G : D ⥤ E} [limits.has_colimit (F ⋙ G)] : limits.colimit (F ⋙ G) ≅ limits.colimit G :=
  as_iso (limits.colimit.pre G F)

/--
When `F` is cofinal, and `F.op ⋙ H` has a limit, then `H` has a limit also and
`limit (F.op ⋙ H) ≅ limit H`

https://stacks.math.columbia.edu/tag/04E7
-/
def limit_iso' {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] {E : Type u} [category E] {H : Dᵒᵖ ⥤ E} [limits.has_limit (functor.op F ⋙ H)] : limits.limit (functor.op F ⋙ H) ≅ limits.limit H :=
  iso.symm (as_iso (limits.limit.pre H (functor.op F)))

/--
If the universal morphism `colimit (F ⋙ coyoneda.obj (op d)) ⟶ colimit (coyoneda.obj (op d))`
is an isomorphism (as it always is when `F` is cofinal),
then `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit`
(simply because `colimit (coyoneda.obj (op d)) ≅ punit`).
-/
def colimit_comp_coyoneda_iso {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] (d : D) [is_iso (limits.colimit.pre (functor.obj coyoneda (opposite.op d)) F)] : limits.colimit (F ⋙ functor.obj coyoneda (opposite.op d)) ≅ PUnit :=
  as_iso (limits.colimit.pre (functor.obj coyoneda (opposite.op d)) F) ≪≫ coyoneda.colimit_coyoneda_iso (opposite.op d)

theorem zigzag_of_eqv_gen_quot_rel {C : Type v} [small_category C] {D : Type v} [small_category D] {F : C ⥤ D} {d : D} {f₁ : sigma fun (X : C) => d ⟶ functor.obj F X} {f₂ : sigma fun (X : C) => d ⟶ functor.obj F X} (t : eqv_gen (limits.types.quot.rel (F ⋙ functor.obj coyoneda (opposite.op d))) f₁ f₂) : zigzag (comma.mk (sigma.snd f₁)) (comma.mk (sigma.snd f₂)) := sorry

/--
If `colimit (F ⋙ coyoneda.obj (op d)) ≅ punit` for all `d : D`, then `F` is cofinal.
-/
theorem cofinal_of_colimit_comp_coyoneda_iso_punit {C : Type v} [small_category C] {D : Type v} [small_category D] (F : C ⥤ D) [cofinal F] (I : (d : D) → limits.colimit (F ⋙ functor.obj coyoneda (opposite.op d)) ≅ PUnit) : cofinal F := sorry


/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group.defs
import data.equiv.basic
import logic.nontrivial

/-!
# Multiplicative opposite and algebraic operations on it

In this file we define `mul_opposite α = αᵐᵒᵖ` to be the multiplicative opposite of `α`. It inherits
all additive algebraic structures on `α` (in other files), and reverses the order of multipliers in
multiplicative structures, i.e., `op (x * y) = op y * op x`, where `mul_opposite.op` is the
canonical map from `α` to `αᵐᵒᵖ`.

We also define `add_opposite α = αᵃᵒᵖ` to be the additive opposite of `α`. It inherits all
multiplicative algebraic structures on `α` (in other files), and reverses the order of summands in
additive structures, i.e. `op (x + y) = op y + op x`, where `add_opposite.op` is the canonical map
from `α` to `αᵃᵒᵖ`.

## Notation

* `αᵐᵒᵖ = mul_opposite α`
* `αᵃᵒᵖ = add_opposite α`

## Tags

multiplicative opposite, additive opposite
-/

universes u v
open function

/-- Multiplicative opposite of a type. This type inherits all additive structures on `α` and
reverses left and right in multiplication.-/
@[to_additive "Additive opposite of a type. This type inherits all multiplicative structures on
`α` and reverses left and right in addition."]
def mul_opposite (α : Type u) : Type u := α

postfix `ᵐᵒᵖ`:std.prec.max_plus := mul_opposite
postfix `ᵃᵒᵖ`:std.prec.max_plus := add_opposite

variables {α : Type u}

namespace mul_opposite

/-- The element of `mul_opposite α` that represents `x : α`. -/
@[pp_nodot, to_additive "The element of `αᵃᵒᵖ` that represents `x : α`."]
def op : α → αᵐᵒᵖ := id

/-- The element of `α` represented by `x : αᵐᵒᵖ`. -/
@[pp_nodot, to_additive "The element of `α` represented by `x : αᵃᵒᵖ`."]
def unop : αᵐᵒᵖ → α := id

attribute [pp_nodot] add_opposite.op add_opposite.unop

@[simp, to_additive] lemma unop_op (x : α) : unop (op x) = x := rfl
@[simp, to_additive] lemma op_unop (x : αᵐᵒᵖ) : op (unop x) = x := rfl
@[simp, to_additive] lemma op_comp_unop : (op : α → αᵐᵒᵖ) ∘ unop = id := rfl
@[simp, to_additive] lemma unop_comp_op : (unop : αᵐᵒᵖ → α) ∘ op = id := rfl

attribute [irreducible] mul_opposite

/-- A recursor for `mul_opposite`. Use as `induction x using mul_opposite.rec`. -/
@[simp, to_additive "A recursor for `add_opposite`. Use as `induction x using add_opposite.rec`."]
protected def rec {F : Π (X : αᵐᵒᵖ), Sort v} (h : Π X, F (op X)) : Π X, F X :=
λ X, h (unop X)

/-- The canonical bijection between `α` and `αᵐᵒᵖ`. -/
@[to_additive "The canonical bijection between `α` and `αᵃᵒᵖ`.",
  simps apply symm_apply { fully_applied := ff }]
def op_equiv : α ≃ αᵐᵒᵖ := ⟨op, unop, unop_op, op_unop⟩

@[to_additive] lemma op_bijective : bijective (op : α → αᵐᵒᵖ) := op_equiv.bijective
@[to_additive] lemma unop_bijective : bijective (unop : αᵐᵒᵖ → α) := op_equiv.symm.bijective
@[to_additive] lemma op_injective : injective (op : α → αᵐᵒᵖ) := op_bijective.injective
@[to_additive] lemma op_surjective : surjective (op : α → αᵐᵒᵖ) := op_bijective.surjective
@[to_additive] lemma unop_injective : injective (unop : αᵐᵒᵖ → α) := unop_bijective.injective
@[to_additive] lemma unop_surjective : surjective (unop : αᵐᵒᵖ → α) := unop_bijective.surjective

@[simp, to_additive] lemma op_inj {x y : α} : op x = op y ↔ x = y := op_injective.eq_iff
@[simp, to_additive] lemma unop_inj {x y : αᵐᵒᵖ} : unop x = unop y ↔ x = y := unop_injective.eq_iff

variable (α)

@[to_additive] instance [nontrivial α] : nontrivial αᵐᵒᵖ := op_injective.nontrivial
@[to_additive] instance [inhabited α] : inhabited αᵐᵒᵖ := ⟨op default⟩
@[to_additive] instance [subsingleton α] : subsingleton αᵐᵒᵖ := unop_injective.subsingleton
@[to_additive] instance [unique α] : unique αᵐᵒᵖ := unique.mk' _
@[to_additive] instance [is_empty α] : is_empty αᵐᵒᵖ := function.is_empty unop

instance [has_zero α] : has_zero αᵐᵒᵖ := { zero := op 0 }

@[to_additive] instance [has_one α] : has_one αᵐᵒᵖ := { one := op 1 }

instance [has_add α] : has_add αᵐᵒᵖ :=
{ add := λ x y, op (unop x + unop y) }

instance [has_sub α] : has_sub αᵐᵒᵖ :=
{ sub := λ x y, op (unop x - unop y) }

instance [has_neg α] : has_neg αᵐᵒᵖ :=
{ neg := λ x, op $ -(unop x) }

@[to_additive] instance [has_mul α] : has_mul αᵐᵒᵖ :=
{ mul := λ x y, op (unop y * unop x) }

@[to_additive] instance [has_inv α] : has_inv αᵐᵒᵖ :=
{ inv := λ x, op $ (unop x)⁻¹ }

@[to_additive] instance (R : Type*) [has_scalar R α] : has_scalar R αᵐᵒᵖ :=
{ smul := λ c x, op (c • unop x) }

section
variables (α)

@[simp] lemma op_zero [has_zero α] : op (0 : α) = 0 := rfl
@[simp]

@[simp, to_additive] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp, to_additive] lemma unop_one [has_one α] : unop (1 : αᵐᵒᵖ) = 1 := rfl

variable {α}

@[simp] lemma op_add [has_add α] (x y : α) : op (x + y) = op x + op y := rfl
@[simp] lemma unop_add [has_add α] (x y : αᵐᵒᵖ) : unop (x + y) = unop x + unop y := rfl

@[simp] lemma op_neg [has_neg α] (x : α) : op (-x) = -op x := rfl
@[simp] lemma unop_neg [has_neg α] (x : αᵐᵒᵖ) : unop (-x) = -unop x := rfl

@[simp, to_additive] lemma op_mul [has_mul α] (x y : α) : op (x * y) = op y * op x := rfl
@[simp, to_additive] lemma unop_mul [has_mul α] (x y : αᵐᵒᵖ) : unop (x * y) = unop y * unop x := rfl

@[simp, to_additive] lemma op_inv [has_inv α] (x : α) : op (x⁻¹) = (op x)⁻¹ := rfl
@[simp, to_additive] lemma unop_inv [has_inv α] (x : αᵐᵒᵖ) : unop (x⁻¹) = (unop x)⁻¹ := rfl

@[simp] lemma op_sub [has_sub α] (x y : α) : op (x - y) = op x - op y := rfl
@[simp] lemma unop_sub [has_sub α] (x y : αᵐᵒᵖ) : unop (x - y) = unop x - unop y := rfl

@[simp, to_additive] lemma op_smul {R : Type*} [has_scalar R α] (c : R) (a : α) :
  op (c • a) = c • op a := rfl

@[simp, to_additive] lemma unop_smul {R : Type*} [has_scalar R α] (c : R) (a : αᵐᵒᵖ) :
  unop (c • a) = c • unop a := rfl

end

variable {α}

@[simp] lemma unop_eq_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop = (0 : α) ↔ a = (0 : αᵐᵒᵖ) :=
unop_injective.eq_iff' rfl

@[simp] lemma op_eq_zero_iff [has_zero α] (a : α) : op a = (0 : αᵐᵒᵖ) ↔ a = (0 : α) :=
op_injective.eq_iff' rfl

lemma unop_ne_zero_iff [has_zero α] (a : αᵐᵒᵖ) : a.unop ≠ (0 : α) ↔ a ≠ (0 : αᵐᵒᵖ) :=
not_congr $ unop_eq_zero_iff a

lemma op_ne_zero_iff [has_zero α] (a : α) : op a ≠ (0 : αᵐᵒᵖ) ↔ a ≠ (0 : α) :=
not_congr $ op_eq_zero_iff a

@[simp, to_additive] lemma unop_eq_one_iff [has_one α] (a : αᵐᵒᵖ) : a.unop = 1 ↔ a = 1 :=
unop_injective.eq_iff' rfl

@[simp, to_additive] lemma op_eq_one_iff [has_one α] (a : α) : op a = 1 ↔ a = 1 :=
op_injective.eq_iff' rfl

end mul_opposite

namespace add_opposite

instance [has_one α] : has_one αᵃᵒᵖ := { one := op 1 }

@[simp] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp] lemma unop_one [has_one α] : unop 1 = (1 : α) := rfl

@[simp] lemma op_eq_one_iff [has_one α] {a : α} : op a = 1 ↔ a = 1 := op_injective.eq_iff' op_one

@[simp] lemma unop_eq_one_iff [has_one α] {a : αᵃᵒᵖ} : unop a = 1 ↔ a = 1 :=
unop_injective.eq_iff' unop_one

instance [has_mul α] : has_mul αᵃᵒᵖ := { mul := λ a b, op (unop a * unop b) }

@[simp] lemma op_mul [has_mul α] (a b : α) : op (a * b) = op a * op b := rfl
@[simp] lemma unop_mul [has_mul α] (a b : αᵃᵒᵖ) : unop (a * b) = unop a * unop b := rfl

instance [has_inv α] : has_inv αᵃᵒᵖ := { inv := λ a, op (unop a)⁻¹ }

@[simp] lemma op_inv [has_inv α] (a : α) : op a⁻¹ = (op a)⁻¹ := rfl
@[simp] lemma unop_inv [has_inv α] (a : αᵃᵒᵖ) : unop a⁻¹ = (unop a)⁻¹ := rfl

instance [has_div α] : has_div αᵃᵒᵖ := { div := λ a b, op (unop a / unop b) }

@[simp] lemma op_div [has_div α] (a b : α) : op (a / b) = op a / op b := rfl
@[simp] lemma unop_div [has_div α] (a b : α) : unop (a / b) = unop a / unop b := rfl

end add_opposite


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

Lift filters along filter and set functions.
-/
import order.filter.basic

open lattice set

local attribute [instance] classical.prop_decidable

namespace filter
variables {α : Type*} {β : Type*} {γ : Type*} {ι : Sort*}

section lift

/-- A variant on `bind` using a function `g` taking a set instead of a member of `α`.
This is essentially a push-forward along a function mapping each set to a filter. -/
protected def lift (f : filter α) (g : set α → filter β) :=
⨅s ∈ f.sets, g s

variables {f f₁ f₂ : filter α} {g g₁ g₂ : set α → filter β}

lemma lift_sets_eq (hg : monotone g) : (f.lift g).sets = (⋃t∈f.sets, (g t).sets) :=
infi_sets_eq'
  (assume s hs t ht, ⟨s ∩ t, inter_mem_sets hs ht,
    hg $ inter_subset_left s t, hg $ inter_subset_right s t⟩)
  ⟨univ, univ_mem_sets⟩

lemma mem_lift {s : set β} {t : set α} (ht : t ∈ f.sets) (hs : s ∈ (g t).sets) :
  s ∈ (f.lift g).sets :=
le_principal_iff.mp $ show f.lift g ≤ principal s,
  from infi_le_of_le t $ infi_le_of_le ht $ le_principal_iff.mpr hs

lemma mem_lift_sets (hg : monotone g) {s : set β} :
  s ∈ (f.lift g).sets ↔ (∃t∈f.sets, s ∈ (g t).sets) :=
by rw [lift_sets_eq hg]; simp only [mem_Union]

lemma lift_le {f : filter α} {g : set α → filter β} {h : filter β} {s : set α}
  (hs : s ∈ f.sets) (hg : g s ≤ h) : f.lift g ≤ h :=
infi_le_of_le s $ infi_le_of_le hs $ hg

lemma le_lift {f : filter α} {g : set α → filter β} {h : filter β}
  (hh : ∀s∈f.sets, h ≤ g s) : h ≤ f.lift g :=
le_infi $ assume s, le_infi $ assume hs, hh s hs

lemma lift_mono (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) : f₁.lift g₁ ≤ f₂.lift g₂ :=
infi_le_infi $ assume s, infi_le_infi2 $ assume hs, ⟨hf hs, hg s⟩

lemma lift_mono' (hg : ∀s∈f.sets, g₁ s ≤ g₂ s) : f.lift g₁ ≤ f.lift g₂ :=
infi_le_infi $ assume s, infi_le_infi $ assume hs, hg s hs

lemma map_lift_eq {m : β → γ} (hg : monotone g) : map m (f.lift g) = f.lift (map m ∘ g) :=
have monotone (map m ∘ g),
  from monotone_comp hg monotone_map,
filter_eq $ set.ext $
  by simp only [mem_lift_sets, hg, @mem_lift_sets _ _ f _ this, exists_prop, forall_const, mem_map, iff_self, function.comp_app]

lemma comap_lift_eq {m : γ → β} (hg : monotone g) : comap m (f.lift g) = f.lift (comap m ∘ g) :=
have monotone (comap m ∘ g),
  from monotone_comp hg monotone_comap,
filter_eq $ set.ext begin
  simp only [hg, @mem_lift_sets _ _ f _ this, comap, mem_lift_sets, mem_set_of_eq, exists_prop,
    function.comp_apply],
  exact λ s,
   ⟨λ ⟨b, ⟨a, ha, hb⟩, hs⟩, ⟨a, ha, b, hb, hs⟩,
    λ ⟨a, ha, b, hb, hs⟩, ⟨b, ⟨a, ha, hb⟩, hs⟩⟩
end

theorem comap_lift_eq2 {m : β → α} {g : set β → filter γ} (hg : monotone g) :
  (comap m f).lift g = f.lift (g ∘ preimage m) :=
le_antisymm
  (le_infi $ assume s, le_infi $ assume hs,
    infi_le_of_le (preimage m s) $ infi_le _ ⟨s, hs, subset.refl _⟩)
  (le_infi $ assume s, le_infi $ assume ⟨s', hs', (h_sub : preimage m s' ⊆ s)⟩,
    infi_le_of_le s' $ infi_le_of_le hs' $ hg h_sub)

lemma map_lift_eq2 {g : set β → filter γ} {m : α → β} (hg : monotone g) :
  (map m f).lift g = f.lift (g ∘ image m) :=
le_antisymm
  (infi_le_infi2 $ assume s, ⟨image m s,
    infi_le_infi2 $ assume hs, ⟨
      f.sets_of_superset hs $ assume a h, mem_image_of_mem _ h,
      le_refl _⟩⟩)
  (infi_le_infi2 $ assume t, ⟨preimage m t,
    infi_le_infi2 $ assume ht, ⟨ht,
      hg $ assume x, assume h : x ∈ m '' preimage m t,
        let ⟨y, hy, h_eq⟩ := h in
        show x ∈ t, from h_eq ▸ hy⟩⟩)

lemma lift_comm {g : filter β} {h : set α → set β → filter γ} :
  f.lift (λs, g.lift (h s)) = g.lift (λt, f.lift (λs, h s t)) :=
le_antisymm
  (le_infi $ assume i, le_infi $ assume hi, le_infi $ assume j, le_infi $ assume hj,
    infi_le_of_le j $ infi_le_of_le hj $ infi_le_of_le i $ infi_le _ hi)
  (le_infi $ assume i, le_infi $ assume hi, le_infi $ assume j, le_infi $ assume hj,
    infi_le_of_le j $ infi_le_of_le hj $ infi_le_of_le i $ infi_le _ hi)

lemma lift_assoc {h : set β → filter γ} (hg : monotone g)  :
  (f.lift g).lift h = f.lift (λs, (g s).lift h) :=
le_antisymm
  (le_infi $ assume s, le_infi $ assume hs, le_infi $ assume t, le_infi $ assume ht,
    infi_le_of_le t $ infi_le _ $ (mem_lift_sets hg).mpr ⟨_, hs, ht⟩)
  (le_infi $ assume t, le_infi $ assume ht,
    let ⟨s, hs, h'⟩ := (mem_lift_sets hg).mp ht in
    infi_le_of_le s $ infi_le_of_le hs $ infi_le_of_le t $ infi_le _ h')

lemma lift_lift_same_le_lift {g : set α → set α → filter β} :
  f.lift (λs, f.lift (g s)) ≤ f.lift (λs, g s s) :=
le_infi $ assume s, le_infi $ assume hs, infi_le_of_le s $ infi_le_of_le hs $ infi_le_of_le s $ infi_le _ hs

lemma lift_lift_same_eq_lift {g : set α → set α → filter β}
  (hg₁ : ∀s, monotone (λt, g s t)) (hg₂ : ∀t, monotone (λs, g s t)):
  f.lift (λs, f.lift (g s)) = f.lift (λs, g s s) :=
le_antisymm
  lift_lift_same_le_lift
  (le_infi $ assume s, le_infi $ assume hs, le_infi $ assume t, le_infi $ assume ht,
    infi_le_of_le (s ∩ t) $
    infi_le_of_le (inter_mem_sets hs ht) $
    calc g (s ∩ t) (s ∩ t) ≤ g s (s ∩ t) : hg₂ (s ∩ t) (inter_subset_left _ _)
      ... ≤ g s t                        : hg₁ s (inter_subset_right _ _))

lemma lift_principal {s : set α} (hg : monotone g) :
  (principal s).lift g = g s :=
le_antisymm
  (infi_le_of_le s $ infi_le _ $ subset.refl _)
  (le_infi $ assume t, le_infi $ assume hi, hg hi)

theorem monotone_lift [preorder γ] {f : γ → filter α} {g : γ → set α → filter β}
  (hf : monotone f) (hg : monotone g) : monotone (λc, (f c).lift (g c)) :=
assume a b h, lift_mono (hf h) (hg h)

lemma lift_neq_bot_iff (hm : monotone g) : (f.lift g ≠ ⊥) ↔ (∀s∈f.sets, g s ≠ ⊥) :=
classical.by_cases
  (assume hn : nonempty β,
    calc f.lift g ≠ ⊥ ↔ (⨅s : { s // s ∈ f.sets}, g s.val) ≠ ⊥ :
      by simp only [filter.lift, infi_subtype, iff_self, ne.def]
      ... ↔ (∀s:{ s // s ∈ f.sets}, g s.val ≠ ⊥) :
        infi_neq_bot_iff_of_directed hn
          (assume ⟨a, ha⟩ ⟨b, hb⟩, ⟨⟨a ∩ b, inter_mem_sets ha hb⟩,
            hm $ inter_subset_left _ _, hm $ inter_subset_right _ _⟩)
      ... ↔ (∀s∈f.sets, g s ≠ ⊥) : ⟨assume h s hs, h ⟨s, hs⟩, assume h ⟨s, hs⟩, h s hs⟩)
  (assume hn : ¬ nonempty β,
    have h₁ : f.lift g = ⊥, from filter_eq_bot_of_not_nonempty hn,
    have h₂ : ∀s, g s = ⊥, from assume s, filter_eq_bot_of_not_nonempty hn,
    calc (f.lift g ≠ ⊥) ↔ false : by simp only [h₁, iff_self, eq_self_iff_true, not_true, ne.def]
      ... ↔ (∀s∈f.sets, false) : ⟨false.elim, assume h, h univ univ_mem_sets⟩
      ... ↔ (∀s∈f.sets, g s ≠ ⊥) : by simp only [h₂, iff_self, eq_self_iff_true, not_true, ne.def])

@[simp] lemma lift_const {f : filter α} {g : filter β} : f.lift (λx, g) = g :=
le_antisymm (lift_le univ_mem_sets $ le_refl g) (le_lift $ assume s hs, le_refl g)

@[simp] lemma lift_inf {f : filter α} {g h : set α → filter β} :
  f.lift (λx, g x ⊓ h x) = f.lift g ⊓ f.lift h :=
by simp only [filter.lift, infi_inf_eq, eq_self_iff_true]

@[simp] lemma lift_principal2 {f : filter α} : f.lift principal = f :=
le_antisymm
  (assume s hs, mem_lift hs (mem_principal_self s))
  (le_infi $ assume s, le_infi $ assume hs, by simp only [hs, le_principal_iff])

lemma lift_infi {f : ι → filter α} {g : set α → filter β}
  (hι : nonempty ι) (hg : ∀{s t}, g s ⊓ g t = g (s ∩ t)) : (infi f).lift g = (⨅i, (f i).lift g) :=
le_antisymm
  (le_infi $ assume i, lift_mono (infi_le _ _) (le_refl _))
  (assume s,
    have g_mono : monotone g,
      from assume s t h, le_of_inf_eq $ eq.trans hg $ congr_arg g $ inter_eq_self_of_subset_left h,
    have ∀t∈(infi f).sets, (⨅ (i : ι), filter.lift (f i) g) ≤ g t,
      from assume t ht, infi_sets_induct ht
        (let ⟨i⟩ := hι in infi_le_of_le i $ infi_le_of_le univ $ infi_le _ univ_mem_sets)
        (assume i s₁ s₂ hs₁ hs₂,
          @hg s₁ s₂ ▸ le_inf (infi_le_of_le i $ infi_le_of_le s₁ $ infi_le _ hs₁) hs₂)
        (assume s₁ s₂ hs₁ hs₂, le_trans hs₂ $ g_mono hs₁),
    begin
      rw [lift_sets_eq g_mono],
      simp only [mem_Union, exists_imp_distrib],
      exact assume t ht hs, this t ht hs
    end)

end lift

section lift'
/-- Specialize `lift` to functions `set α → set β`. This can be viewed as a generalization of `map`.
This is essentially a push-forward along a function mapping each set to a set. -/
protected def lift' (f : filter α) (h : set α → set β) :=
f.lift (principal ∘ h)

variables {f f₁ f₂ : filter α} {h h₁ h₂ : set α → set β}

lemma mem_lift' {t : set α} (ht : t ∈ f.sets) : h t ∈ (f.lift' h).sets :=
le_principal_iff.mp $ show f.lift' h ≤ principal (h t),
  from infi_le_of_le t $ infi_le_of_le ht $ le_refl _

lemma mem_lift'_sets (hh : monotone h) {s : set β} : s ∈ (f.lift' h).sets ↔ (∃t∈f.sets, h t ⊆ s) :=
have monotone (principal ∘ h),
  from assume a b h, principal_mono.mpr $ hh h,
by simp only [filter.lift', @mem_lift_sets α β f _ this, exists_prop, iff_self, mem_principal_sets, function.comp_app]

lemma lift'_le {f : filter α} {g : set α → set β} {h : filter β} {s : set α}
  (hs : s ∈ f.sets) (hg : principal (g s) ≤ h) : f.lift' g ≤ h :=
lift_le hs hg

lemma lift'_mono (hf : f₁ ≤ f₂) (hh : h₁ ≤ h₂) : f₁.lift' h₁ ≤ f₂.lift' h₂ :=
lift_mono hf $ assume s, principal_mono.mpr $ hh s

lemma lift'_mono' (hh : ∀s∈f.sets, h₁ s ⊆ h₂ s) : f.lift' h₁ ≤ f.lift' h₂ :=
infi_le_infi $ assume s, infi_le_infi $ assume hs, principal_mono.mpr $ hh s hs

lemma lift'_cong (hh : ∀s∈f.sets, h₁ s = h₂ s) : f.lift' h₁ = f.lift' h₂ :=
le_antisymm (lift'_mono' $ assume s hs, le_of_eq $ hh s hs) (lift'_mono' $ assume s hs, le_of_eq $ (hh s hs).symm)

lemma map_lift'_eq {m : β → γ} (hh : monotone h) : map m (f.lift' h) = f.lift' (image m ∘ h) :=
calc map m (f.lift' h) = f.lift (map m ∘ principal ∘ h) :
    map_lift_eq $ monotone_comp hh monotone_principal
  ... = f.lift' (image m ∘ h) : by simp only [(∘), filter.lift', map_principal, eq_self_iff_true]

lemma map_lift'_eq2 {g : set β → set γ} {m : α → β} (hg : monotone g) :
  (map m f).lift' g = f.lift' (g ∘ image m) :=
map_lift_eq2 $ monotone_comp hg monotone_principal

theorem comap_lift'_eq {m : γ → β} (hh : monotone h) :
  comap m (f.lift' h) = f.lift' (preimage m ∘ h) :=
calc comap m (f.lift' h) = f.lift (comap m ∘ principal ∘ h) :
    comap_lift_eq $ monotone_comp hh monotone_principal
  ... = f.lift' (preimage m ∘ h) : by simp only [(∘), filter.lift', comap_principal, eq_self_iff_true]

theorem comap_lift'_eq2 {m : β → α} {g : set β → set γ} (hg : monotone g) :
  (comap m f).lift' g = f.lift' (g ∘ preimage m) :=
comap_lift_eq2 $ monotone_comp hg monotone_principal

lemma lift'_principal {s : set α} (hh : monotone h) :
  (principal s).lift' h = principal (h s) :=
lift_principal $ monotone_comp hh monotone_principal

lemma principal_le_lift' {t : set β} (hh : ∀s∈f.sets, t ⊆ h s) :
  principal t ≤ f.lift' h :=
le_infi $ assume s, le_infi $ assume hs, principal_mono.mpr (hh s hs)

theorem monotone_lift' [preorder γ] {f : γ → filter α} {g : γ → set α → set β}
  (hf : monotone f) (hg : monotone g) : monotone (λc, (f c).lift' (g c)) :=
assume a b h, lift'_mono (hf h) (hg h)

lemma lift_lift'_assoc {g : set α → set β} {h : set β → filter γ}
  (hg : monotone g) (hh : monotone h) :
  (f.lift' g).lift h = f.lift (λs, h (g s)) :=
calc (f.lift' g).lift h = f.lift (λs, (principal (g s)).lift h) :
    lift_assoc (monotone_comp hg monotone_principal)
  ... = f.lift (λs, h (g s)) : by simp only [lift_principal, hh, eq_self_iff_true]

lemma lift'_lift'_assoc {g : set α → set β} {h : set β → set γ}
  (hg : monotone g) (hh : monotone h) :
  (f.lift' g).lift' h = f.lift' (λs, h (g s)) :=
lift_lift'_assoc hg (monotone_comp hh monotone_principal)

lemma lift'_lift_assoc {g : set α → filter β} {h : set β → set γ}
  (hg : monotone g) : (f.lift g).lift' h = f.lift (λs, (g s).lift' h) :=
lift_assoc hg

lemma lift_lift'_same_le_lift' {g : set α → set α → set β} :
  f.lift (λs, f.lift' (g s)) ≤ f.lift' (λs, g s s) :=
lift_lift_same_le_lift

lemma lift_lift'_same_eq_lift' {g : set α → set α → set β}
  (hg₁ : ∀s, monotone (λt, g s t)) (hg₂ : ∀t, monotone (λs, g s t)):
  f.lift (λs, f.lift' (g s)) = f.lift' (λs, g s s) :=
lift_lift_same_eq_lift
  (assume s, monotone_comp monotone_id $ monotone_comp (hg₁ s) monotone_principal)
  (assume t, monotone_comp (hg₂ t) monotone_principal)

lemma lift'_inf_principal_eq {h : set α → set β} {s : set β} :
  f.lift' h ⊓ principal s = f.lift' (λt, h t ∩ s) :=
le_antisymm
  (le_infi $ assume t, le_infi $ assume ht,
    calc filter.lift' f h ⊓ principal s ≤ principal (h t) ⊓ principal s :
        inf_le_inf (infi_le_of_le t $ infi_le _ ht) (le_refl _)
      ... = _ : by simp only [principal_eq_iff_eq, inf_principal, eq_self_iff_true, function.comp_app])
  (le_inf
    (le_infi $ assume t, le_infi $ assume ht,
      infi_le_of_le t $ infi_le_of_le ht $
      by simp only [le_principal_iff, inter_subset_left, mem_principal_sets, function.comp_app]; exact inter_subset_right _ _)
    (infi_le_of_le univ $ infi_le_of_le univ_mem_sets $
    by simp only [le_principal_iff, inter_subset_right, mem_principal_sets, function.comp_app]; exact inter_subset_left _ _))

lemma lift'_neq_bot_iff (hh : monotone h) : (f.lift' h ≠ ⊥) ↔ (∀s∈f.sets, h s ≠ ∅) :=
calc (f.lift' h ≠ ⊥) ↔ (∀s∈f.sets, principal (h s) ≠ ⊥) :
    lift_neq_bot_iff (monotone_comp hh monotone_principal)
  ... ↔ (∀s∈f.sets, h s ≠ ∅) : by simp only [principal_eq_bot_iff, iff_self, ne.def, principal_eq_bot_iff]

@[simp] lemma lift'_id {f : filter α} : f.lift' id = f :=
lift_principal2

lemma le_lift' {f : filter α} {h : set α → set β} {g : filter β}
  (h_le : ∀s∈f.sets, h s ∈ g.sets) : g ≤ f.lift' h :=
le_infi $ assume s, le_infi $ assume hs, by simp only [h_le, le_principal_iff, function.comp_app]; exact h_le s hs

lemma lift_infi' {f : ι → filter α} {g : set α → filter β}
  (hι : nonempty ι) (hf : directed (≥) f) (hg : monotone g) : (infi f).lift g = (⨅i, (f i).lift g) :=
le_antisymm
  (le_infi $ assume i, lift_mono (infi_le _ _) (le_refl _))
  (assume s,
  begin
    rw [lift_sets_eq hg],
    simp only [mem_Union, exists_imp_distrib, infi_sets_eq hf hι],
    exact assume t i ht hs, mem_infi_sets i $ mem_lift ht hs
  end)

lemma lift'_infi {f : ι → filter α} {g : set α → set β}
  (hι : nonempty ι) (hg : ∀{s t}, g s ∩ g t = g (s ∩ t)) : (infi f).lift' g = (⨅i, (f i).lift' g) :=
lift_infi hι $ by simp only [principal_eq_iff_eq, inf_principal, function.comp_app]; apply assume s t, hg

theorem comap_eq_lift' {f : filter β} {m : α → β} :
  comap m f = f.lift' (preimage m) :=
filter_eq $ set.ext $ by simp only [mem_lift'_sets, monotone_preimage, comap, exists_prop, forall_const, iff_self, mem_set_of_eq]

end lift'

section prod
variables {f : filter α}

lemma prod_def {f : filter α} {g : filter β} : f.prod g = (f.lift $ λs, g.lift' $ set.prod s) :=
have ∀(s:set α) (t : set β),
    principal (set.prod s t) = (principal s).comap prod.fst ⊓ (principal t).comap prod.snd,
  by simp only [principal_eq_iff_eq, comap_principal, inf_principal]; intros; refl,
begin
  simp only [filter.lift', function.comp, this, -comap_principal, lift_inf, lift_const, lift_inf],
  rw [← comap_lift_eq monotone_principal, ← comap_lift_eq monotone_principal],
  simp only [filter.prod, lift_principal2, eq_self_iff_true]
end

lemma prod_same_eq : filter.prod f f = f.lift' (λt, set.prod t t) :=
by rw [prod_def];
from lift_lift'_same_eq_lift'
  (assume s, set.monotone_prod monotone_const monotone_id)
  (assume t, set.monotone_prod monotone_id monotone_const)

lemma mem_prod_same_iff {s : set (α×α)} :
  s ∈ (filter.prod f f).sets ↔ (∃t∈f.sets, set.prod t t ⊆ s) :=
by rw [prod_same_eq, mem_lift'_sets]; exact set.monotone_prod monotone_id monotone_id

lemma tendsto_prod_self_iff {f : α × α → β} {x : filter α} {y : filter β} :
  filter.tendsto f (filter.prod x x) y ↔
  ∀ W ∈ y.sets, ∃ U ∈ x.sets, ∀ (x x' : α), x ∈ U → x' ∈ U → f (x, x') ∈ W :=
by simp only [tendsto_def, mem_prod_same_iff, prod_sub_preimage_iff, exists_prop, iff_self]

variables {α₁ : Type*} {α₂ : Type*} {β₁ : Type*} {β₂ : Type*}

lemma prod_lift_lift
  {f₁ : filter α₁} {f₂ : filter α₂} {g₁ : set α₁ → filter β₁} {g₂ : set α₂ → filter β₂}
  (hg₁ : monotone g₁) (hg₂ : monotone g₂) :
  filter.prod (f₁.lift g₁) (f₂.lift g₂) = f₁.lift (λs, f₂.lift (λt, filter.prod (g₁ s) (g₂ t))) :=
begin
  simp only [prod_def],
  rw [lift_assoc],
  apply congr_arg, funext x,
  rw [lift_comm],
  apply congr_arg, funext y,
  rw [lift'_lift_assoc],
  exact hg₂,
  exact hg₁
end

lemma prod_lift'_lift'
  {f₁ : filter α₁} {f₂ : filter α₂} {g₁ : set α₁ → set β₁} {g₂ : set α₂ → set β₂}
  (hg₁ : monotone g₁) (hg₂ : monotone g₂) :
  filter.prod (f₁.lift' g₁) (f₂.lift' g₂) = f₁.lift (λs, f₂.lift' (λt, set.prod (g₁ s) (g₂ t))) :=
begin
  rw [prod_def, lift_lift'_assoc],
  apply congr_arg, funext x,
  rw [lift'_lift'_assoc],
  exact hg₂,
  exact set.monotone_prod monotone_const monotone_id,
  exact hg₁,
  exact (monotone_lift' monotone_const $ monotone_lam $
    assume x, set.monotone_prod monotone_id monotone_const)
end

end prod

end filter


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.algebra.ring.pi
import Mathlib.PostPort

universes u v u_1 u_2

namespace Mathlib

/-!
# Pi instances for module and multiplicative actions

This file defines instances for module, mul_action and related structures on Pi Types
-/

namespace pi

protected instance has_scalar {I : Type u} {f : I → Type v} {α : Type u_1} [(i : I) → has_scalar α (f i)] : has_scalar α ((i : I) → f i) :=
  has_scalar.mk fun (s : α) (x : (i : I) → f i) (i : I) => s • x i

@[simp] theorem smul_apply {I : Type u} {f : I → Type v} (x : (i : I) → f i) (i : I) {α : Type u_1} [(i : I) → has_scalar α (f i)] (s : α) : has_scalar.smul s x i = s • x i :=
  rfl

protected instance has_scalar' {I : Type u} {f : I → Type v} {g : I → Type u_1} [(i : I) → has_scalar (f i) (g i)] : has_scalar ((i : I) → f i) ((i : I) → g i) :=
  has_scalar.mk fun (s : (i : I) → f i) (x : (i : I) → g i) (i : I) => s i • x i

@[simp] theorem smul_apply' {I : Type u} {f : I → Type v} (i : I) {g : I → Type u_1} [(i : I) → has_scalar (f i) (g i)] (s : (i : I) → f i) (x : (i : I) → g i) : has_scalar.smul s x i = s i • x i :=
  rfl

protected instance is_scalar_tower {I : Type u} {f : I → Type v} {α : Type u_1} {β : Type u_2} [has_scalar α β] [(i : I) → has_scalar β (f i)] [(i : I) → has_scalar α (f i)] [∀ (i : I), is_scalar_tower α β (f i)] : is_scalar_tower α β ((i : I) → f i) :=
  is_scalar_tower.mk fun (x : α) (y : β) (z : (i : I) → f i) => funext fun (i : I) => smul_assoc x y (z i)

protected instance is_scalar_tower' {I : Type u} {f : I → Type v} {g : I → Type u_1} {α : Type u_2} [(i : I) → has_scalar α (f i)] [(i : I) → has_scalar (f i) (g i)] [(i : I) → has_scalar α (g i)] [∀ (i : I), is_scalar_tower α (f i) (g i)] : is_scalar_tower α ((i : I) → f i) ((i : I) → g i) :=
  is_scalar_tower.mk fun (x : α) (y : (i : I) → f i) (z : (i : I) → g i) => funext fun (i : I) => smul_assoc x (y i) (z i)

protected instance is_scalar_tower'' {I : Type u} {f : I → Type v} {g : I → Type u_1} {h : I → Type u_2} [(i : I) → has_scalar (f i) (g i)] [(i : I) → has_scalar (g i) (h i)] [(i : I) → has_scalar (f i) (h i)] [∀ (i : I), is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower ((i : I) → f i) ((i : I) → g i) ((i : I) → h i) :=
  is_scalar_tower.mk
    fun (x : (i : I) → f i) (y : (i : I) → g i) (z : (i : I) → h i) => funext fun (i : I) => smul_assoc (x i) (y i) (z i)

protected instance mul_action {I : Type u} {f : I → Type v} (α : Type u_1) {m : monoid α} [(i : I) → mul_action α (f i)] : mul_action α ((i : I) → f i) :=
  mul_action.mk sorry sorry

protected instance mul_action' {I : Type u} {f : I → Type v} {g : I → Type u_1} {m : (i : I) → monoid (f i)} [(i : I) → mul_action (f i) (g i)] : mul_action ((i : I) → f i) ((i : I) → g i) :=
  mul_action.mk sorry sorry

protected instance distrib_mul_action {I : Type u} {f : I → Type v} (α : Type u_1) {m : monoid α} {n : (i : I) → add_monoid (f i)} [(i : I) → distrib_mul_action α (f i)] : distrib_mul_action α ((i : I) → f i) :=
  distrib_mul_action.mk sorry sorry

protected instance distrib_mul_action' {I : Type u} {f : I → Type v} {g : I → Type u_1} {m : (i : I) → monoid (f i)} {n : (i : I) → add_monoid (g i)} [(i : I) → distrib_mul_action (f i) (g i)] : distrib_mul_action ((i : I) → f i) ((i : I) → g i) :=
  distrib_mul_action.mk sorry sorry

protected instance semimodule (I : Type u) (f : I → Type v) (α : Type u_1) {r : semiring α} {m : (i : I) → add_comm_monoid (f i)} [(i : I) → semimodule α (f i)] : semimodule α ((i : I) → f i) :=
  semimodule.mk sorry sorry

protected instance semimodule' {I : Type u} {f : I → Type v} {g : I → Type u_1} {r : (i : I) → semiring (f i)} {m : (i : I) → add_comm_monoid (g i)} [(i : I) → semimodule (f i) (g i)] : semimodule ((i : I) → f i) ((i : I) → g i) :=
  semimodule.mk sorry sorry


/-
Copyright (c) 2020 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.mv_polynomial.rename
import Mathlib.PostPort

universes u_1 u_2 u_4 u_3

namespace Mathlib

/-!
# `comap` operation on `mv_polynomial`

This file defines the `comap` function on `mv_polynomial`.

`mv_polynomial.comap` is a low-tech example of a map of "algebraic varieties," modulo the fact that
`mathlib` does not yet define varieties.

## Notation

As in other polynomial files, we typically use the notation:

+ `σ : Type*` (indexing the variables)

+ `R : Type*` `[comm_semiring R]` (the coefficients)

-/

namespace mv_polynomial

/--
Given an algebra hom `f : mv_polynomial σ R →ₐ[R] mv_polynomial τ R`
and a variable evaluation `v : τ → R`,
`comap f v` produces a variable evaluation `σ → R`.
-/
def comap {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R]
    (f : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R)) : (τ → R) → σ → R :=
  fun (x : τ → R) (i : σ) => coe_fn (aeval x) (coe_fn f (X i))

@[simp] theorem comap_apply {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R]
    (f : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R)) (x : τ → R) (i : σ) :
    comap f x i = coe_fn (aeval x) (coe_fn f (X i)) :=
  rfl

@[simp] theorem comap_id_apply {σ : Type u_1} {R : Type u_4} [comm_semiring R] (x : σ → R) :
    comap (alg_hom.id R (mv_polynomial σ R)) x = x :=
  sorry

theorem comap_id (σ : Type u_1) (R : Type u_4) [comm_semiring R] :
    comap (alg_hom.id R (mv_polynomial σ R)) = id :=
  funext fun (x : σ → R) => comap_id_apply x

theorem comap_comp_apply {σ : Type u_1} {τ : Type u_2} {υ : Type u_3} {R : Type u_4}
    [comm_semiring R] (f : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R))
    (g : alg_hom R (mv_polynomial τ R) (mv_polynomial υ R)) (x : υ → R) :
    comap (alg_hom.comp g f) x = comap f (comap g x) :=
  sorry

theorem comap_comp {σ : Type u_1} {τ : Type u_2} {υ : Type u_3} {R : Type u_4} [comm_semiring R]
    (f : alg_hom R (mv_polynomial σ R) (mv_polynomial τ R))
    (g : alg_hom R (mv_polynomial τ R) (mv_polynomial υ R)) :
    comap (alg_hom.comp g f) = comap f ∘ comap g :=
  funext fun (x : υ → R) => comap_comp_apply f g x

theorem comap_eq_id_of_eq_id {σ : Type u_1} {R : Type u_4} [comm_semiring R]
    (f : alg_hom R (mv_polynomial σ R) (mv_polynomial σ R))
    (hf : ∀ (φ : mv_polynomial σ R), coe_fn f φ = φ) (x : σ → R) : comap f x = x :=
  sorry

theorem comap_rename {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R] (f : σ → τ)
    (x : τ → R) : comap (rename f) x = x ∘ f :=
  sorry

/--
If two polynomial types over the same coefficient ring `R` are equivalent,
there is a bijection between the types of functions from their variable types to `R`.
-/
def comap_equiv {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R]
    (f : alg_equiv R (mv_polynomial σ R) (mv_polynomial τ R)) : (τ → R) ≃ (σ → R) :=
  equiv.mk (comap ↑f) (comap ↑(alg_equiv.symm f)) sorry sorry

@[simp] theorem comap_equiv_coe {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R]
    (f : alg_equiv R (mv_polynomial σ R) (mv_polynomial τ R)) : ⇑(comap_equiv f) = comap ↑f :=
  rfl

@[simp] theorem comap_equiv_symm_coe {σ : Type u_1} {τ : Type u_2} {R : Type u_4} [comm_semiring R]
    (f : alg_equiv R (mv_polynomial σ R) (mv_polynomial τ R)) :
    ⇑(equiv.symm (comap_equiv f)) = comap ↑(alg_equiv.symm f) :=
  rfl

end Mathlib


import data.real.basic
import data.real.basic tactic.norm_num
import data.nat.basic algebra.group_power
--\medskip\noindent{\bf Q0804.} For each of the following binary relations on a set~$S$,
-- figure out whether or not the relation is reflexive. Then figure out whether or not
--  it is symmetric. Finally figure out whether or not the relation is transitive.

-- intro, exact, assume, cases, split, left, right, norm_num, by refl, by le_refl, rw, unfold, by contradiction, have, let
definition S5 := {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}
definition S6 := {x : ℕ | false}

definition r1 (a b : ℝ) : Prop := a ≤ b
definition r2 (a b : ℤ) : Prop := ∃ k, a - b = k ^ 2
definition r3 (a b : ℝ) : Prop := a = b ^ 2
definition r4 (a b : ℤ) : Prop := a + b = 0

definition r5 (a b : S5) : Prop := (a : ℕ) = 1 ∧ (b : ℕ) = 3
definition r6 (a b : S6) : Prop := true

instance nat.decidable_bex_lt (n : nat) (P : Π k < n, Prop) :
  ∀ [H : ∀ n h, decidable (P n h)], decidable (∃ k h, P k h) :=
begin
  induction n with n IH; intro; resetI,
  { exact is_false (λ ⟨_, h, _⟩, nat.not_lt_zero _ h) },
  cases IH (λ k h, P k (nat.lt_succ_of_lt h)) with h,
  { by_cases p : P n (nat.lt_succ_self n),
    { exact is_true ⟨n, nat.lt_succ_self n, p⟩ },
    { apply is_false,
      intro hk,
      rcases hk with ⟨k, hk1, hk2⟩,
      cases nat.lt_succ_iff_lt_or_eq.1 hk1 with hk hk,
      { exact h ⟨k, hk, hk2⟩ },
      { subst hk, exact p hk2 } } },
  apply is_true,
  rcases h with ⟨k, hk1, hk2⟩,
  exact ⟨k, nat.lt_succ_of_lt hk1, hk2⟩
end

instance nat.decidable_bex_le (n : nat) (P : Π k ≤ n, Prop)
  [Π n h, decidable (P n h)] : decidable (∃ k h, P k h) :=
decidable_of_iff (∃ k < n + 1, P k (nat.le_of_lt_succ H))
⟨λ ⟨k, h1, h2⟩, ⟨k, nat.le_of_lt_succ h1, h2⟩,
λ ⟨k, h1, h2⟩, ⟨k, nat.lt_succ_of_le h1, h2⟩⟩

instance decidable_mul_self_nat (n : ℕ) : decidable (∃ k, k * k = n) :=
decidable_of_iff (∃ k ≤ n, k * k = n)
⟨λ ⟨k, h1, h2⟩, ⟨k, h2⟩, λ ⟨k, h1⟩, ⟨k, h1 ▸ nat.le_mul_self k, h1⟩⟩

instance decidable_sqr_nat (n : ℕ) : decidable (∃ k, k^2 = n) :=
decidable_of_iff (∃ k, k * k = n)
⟨λ ⟨k, h⟩, ⟨k, by rwa [nat.pow_two]⟩, λ ⟨k, h⟩, ⟨k, by rwa [nat.pow_two] at h⟩⟩

instance decidable_mul_self_int : Π (n : ℤ), decidable (∃ k, k * k = n)
| (int.of_nat n) := decidable_of_iff (∃ k, k * k = n)
    ⟨λ ⟨k, hk⟩, ⟨k, by rw [← int.coe_nat_mul, hk]; refl⟩,
    λ ⟨k, hk⟩, ⟨int.nat_abs k, by rw [← int.nat_abs_mul, hk]; refl⟩⟩
| -[1+ n] := is_false $ λ ⟨k, h1⟩, not_lt_of_ge (mul_self_nonneg k) $
    h1.symm ▸ int.neg_succ_of_nat_lt_zero n

instance decidable_sqr_int (n : ℤ) : decidable (∃ k, k^2 = n) :=
decidable_of_iff (∃ k, k * k = n)
⟨λ ⟨k, h⟩, ⟨k, by rwa [pow_two]⟩, λ ⟨k, h⟩, ⟨k, by rwa [pow_two] at h⟩⟩

theorem what_i_need: ¬ (∃ n : ℤ ,  n ^ 2 = 2 ) := dec_trivial
theorem what_i_need_2: ¬ (∃ n : ℤ ,  n ^ 2 = -1 ) := dec_trivial

--nstance h (m : ℤ) : decidable (∃ n : ℤ, n ^ 2 = m) :=
--decidable_of_iff (0 ≤ m ∧ m.nat_abs.sqrt ^ 2 = m.nat_abs)
--⟨λ h, ⟨nat.sqrt m.nat_abs, by rw [← int.coe_nat_pow, h.2, int.nat_abs_of_nonneg h.1]⟩,
--λ ⟨s, hs⟩, ⟨hs ▸ (pow_two_nonneg _), by rw [← hs, pow_two, int.nat_abs_mul, nat.sqrt_eq, nat.pow_two]⟩⟩
--#eval (¬ ∃ n : ℤ, n ^ 2 = 2 : bool)
--lemma two_not_square : ¬ ∃ n : ℤ, n ^ 2 = 2 := tactic.exact_dec_trivial

theorem Q1r : reflexive r1 := begin
unfold reflexive r1,
intro HP,
apply le_refl,
end
theorem Q1s : ¬ (symmetric r1) := begin
unfold symmetric r1,
intro HP,
have h2: (0:ℝ ) ≤ (1:ℝ), by norm_num,
have h3:= HP h2,
have h4: ¬((1:ℝ) ≤ (0:ℝ)), by norm_num,
exact h4 h3,
end
theorem Q1t : transitive r1 := begin
unfold transitive r1,
intro a,
intro b,
intro c,
assume h1 : a ≤ b,
assume h2 : b ≤ c,
apply le_trans,
assumption,
assumption,
end

theorem Q2r : (reflexive r2) := begin
unfold reflexive r2,
intro a,
have h1 : a - a = 0, norm_num,
have h2 : (0 : ℤ) = (0 : ℤ) * (0 : ℤ), norm_num,
existsi (0 : ℤ),
exact h2,
end
theorem Q2s : ¬ (symmetric r2) := begin
unfold symmetric r2,
intro HP,
have h1 : (1: ℤ )-(0: ℤ ) = 1^2, by norm_num,
have h4 := HP(exists.intro(1: ℤ ) h1),
simp at h4,
apply what_i_need_2,
  cases h4 with z hz,
  existsi z,
  rwa eq_comm,
end
theorem Q2t : ¬ (transitive r2) := begin
unfold transitive r2,
intro HP,
have h1: (2:ℤ ) - (1:ℤ ) = 1^2, by refl,
have h2: (1:ℤ ) - (0:ℤ ) = 1^2, by refl,
have h3: (2:ℤ ) - (0:ℤ ) = 2, by norm_num,
have h4 := HP (exists.intro (1: ℤ ) h1)(exists.intro(1:ℤ ) h2),
apply what_i_need,
simp at h4,
cases h4 with z hz,
existsi z,
rw hz,
end

theorem Q3r : ¬ (reflexive r3) := begin
unfold reflexive r3,
intro HP,
let x := (2 :ℝ ),
have h1 : (2 : ℝ ) ≠ (2:ℝ )^2, by norm_num,
have h2 := HP(2: ℝ ),
apply h1,
exact h2,
end
theorem Q3s : ¬ (symmetric r3) := begin
unfold symmetric r3,
intro HP,
let a := (4: ℝ ),
let b := (2: ℝ ),
have h1 : a = b^2, by refl,
have h2 : a^2 = 16, by refl,
have h3 : (2 : ℝ) ≠ 16, by norm_num,
have h4 := HP h1,
have h5 : b= 2, by refl,
rw h2 at h4,
apply h3,
exact h4,
end
theorem Q3t : ¬ (transitive r3) := begin
unfold transitive r3,
intro HP,
have h1: (16: ℝ ) = (4: ℝ )^2, by refl,
have h2: (4:ℝ ) = (2:ℝ )^2, by refl,
have h3: (16: ℝ ) ≠ (2:ℝ )^2, by norm_num,
have h4 := HP h1 h2,
apply h3,
exact h4,
end

theorem Q4r : ¬ (reflexive r4) := begin
unfold reflexive r4,
intro HP,
have h1 : (1:ℤ )+ (1:ℤ ) ≠ (0:ℤ ), by norm_num,
have h2 := HP(1:ℤ ),
apply h1,
exact h2,
end
theorem Q4s : (symmetric r4) := begin
unfold symmetric r4,
intro HP,
intro a,
intro b,
rw add_comm a HP,
exact b,
end
theorem Q4t : ¬ (transitive r4) := begin

unfold transitive r4,
intro HP,
let a:= (1:ℤ) ,
let b:= (-1: ℤ ),
let c:= (1: ℤ ),
have h1 : a + b = 0, by refl,
have h2 : b + c = 0, by refl,
have h3 : a + c = 2, by refl,
have h4 := HP h1 h2,
rw h3 at h4, norm_num at h4,
end

theorem Q5r :  ¬ (reflexive r5) := begin
unfold reflexive r5,
intro HP,
dunfold S5 at HP,
have h1 : (2:ℕ ) ∈ {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}, by norm_num,
have h2 : (2 : ℕ ) ≠ (1 : ℕ ), by norm_num,
have h3 : (2 : ℕ ) ≠ (3 : ℕ ), by norm_num,
have h4 := HP ⟨2, by simp⟩,
apply h2,
exact h4.left,
end
theorem Q5s : ¬ (symmetric r5) := begin
unfold symmetric r5,
intro HP,
dunfold S5 at HP,
have h1 : (1 :ℕ ) ∈ {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}, by norm_num,
have h2 : (3 :ℕ ) ∈ {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}, by norm_num,
have h3 : (1 :ℕ ) ≠ (3 :ℕ ), by norm_num,
have := @HP ⟨(1 : ℕ), by simp⟩ ⟨3, by simp⟩ ⟨rfl, rfl⟩,
apply h3,
exact this.right,
end
theorem Q5t : (transitive r5) := begin
unfold transitive r5,
have h1 : (1 :ℕ ) ∈ {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}, by norm_num,
have h2 : (3 :ℕ ) ∈ {x : ℕ | x = 1 ∨ x = 2 ∨ x = 3 ∨ x = 4}, by norm_num,
have h3 : (1 :ℕ ) ≠ (3 :ℕ ), by norm_num,
have h4 : (3 :ℕ ) ≠ (1 :ℕ ), by norm_num,
finish,
end

theorem Q6r : (reflexive r6) := begin
unfold reflexive r6,
dunfold S6,
simp,
end
theorem Q6s : (symmetric r6) := begin
unfold symmetric r6,
dunfold S6,
simp,
end
theorem Q6t : (transitive r6) := begin
unfold transitive r6,
dunfold S6,
simp,
end