/-
Copyright (c) 2019 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.traversable.basic
import Mathlib.tactic.simpa
import Mathlib.PostPort

namespace Mathlib

/-- pretty print a `loc` -/
/-- shift `pos` `n` columns to the left -/
namespace tactic

/-- parse structure instance of the shape `{ field1 := value1, .. , field2 := value2 }` -/
/-- pretty print structure instance -/
/-- Attribute containing a table that accumulates multiple `squeeze_simp` suggestions -/
/-- dummy declaration used as target of `squeeze_loc` attribute -/
def squeeze_loc_attr_carrier : Unit :=
  Unit.unit

/-- Format a list of arguments for use with `simp` and friends. This omits the
list entirely if it is empty. -/
/-- Emit a suggestion to the user. If inside a `squeeze_scope` block,
the suggestions emitted through `mk_suggestion` will be aggregated so that
every tactic that makes a suggestion can consider multiple execution of the
same invocation.
If `at_pos` is true, make the suggestion at `p` instead of the current position. -/
/-- translate a `pexpr` into a `simp` configuration -/
/-- translate a `pexpr` into a `dsimp` configuration -/
/-- `same_result proof tac` runs tactic `tac` and checks if the proof
produced by `tac` is equivalent to `proof`. -/
/--
`filter_simp_set g call_simp user_args simp_args` returns `args'` such that, when calling
`call_simp tt /- only -/ args'` on the goal `g` (`g` is a meta var) we end up in the same
state as if we had called `call_simp ff (user_args ++ simp_args)` and removing any one
element of `args'` changes the resulting proof.
-/
/-- make a `simp_arg_type` that references the name given as an argument -/
/-- tactic combinator to create a `simp`-like tactic that minimizes its
argument list.

 * `slow`: adds all rfl-lemmas from the environment to the initial list (this is a slower but more accurate strategy)
 * `no_dflt`: did the user use the `only` keyword?
 * `args`:    list of `simp` arguments
 * `tac`:     how to invoke the underlying `simp` tactic

-/
namespace interactive

/-- Turn a `simp_arg_type` into a string. -/
/-- combinator meant to aggregate the suggestions issued by multiple calls
of `squeeze_simp` (due, for instance, to `;`).

Can be used as:

```lean
example {α β} (xs ys : list α) (f : α → β) :
  (xs ++ ys.tail).map f = xs.map f ∧ (xs.tail.map f).length = xs.length :=
begin
  have : xs = ys, admit,
  squeeze_scope
  { split; squeeze_simp, -- `squeeze_simp` is run twice, the first one requires
                         -- `list.map_append` and the second one `[list.length_map, list.length_tail]`
                         -- prints only one message and combine the suggestions:
                         -- > Try this: simp only [list.length_map, list.length_tail, list.map_append]
    squeeze_simp [this]  -- `squeeze_simp` is run only once
                         -- prints:
                         -- > Try this: simp only [this]
 },
end
```

-/
/--
`squeeze_simp`, `squeeze_simpa` and `squeeze_dsimp` perform the same
task with the difference that `squeeze_simp` relates to `simp` while
`squeeze_simpa` relates to `simpa` and `squeeze_dsimp` relates to
`dsimp`. The following applies to `squeeze_simp`, `squeeze_simpa` and
`squeeze_dsimp`.

`squeeze_simp` behaves like `simp` (including all its arguments)
and prints a `simp only` invocation to skip the search through the
`simp` lemma list.

For instance, the following is easily solved with `simp`:

```lean
example : 0 + 1 = 1 + 0 := by simp
```

To guide the proof search and speed it up, we may replace `simp`
with `squeeze_simp`:

```lean
example : 0 + 1 = 1 + 0 := by squeeze_simp
-- prints:

-- prints:
-- Try this: simp only [add_zero, eq_self_iff_true, zero_add]

-- Try this: simp only [add_zero, eq_self_iff_true, zero_add]
```

`squeeze_simp` suggests a replacement which we can use instead of
`squeeze_simp`.

```lean
example : 0 + 1 = 1 + 0 := by simp only [add_zero, eq_self_iff_true, zero_add]
```

`squeeze_simp only` prints nothing as it already skips the `simp` list.

This tactic is useful for speeding up the compilation of a complete file.
Steps:

   1. search and replace ` simp` with ` squeeze_simp` (the space helps avoid the
      replacement of `simp` in `@[simp]`) throughout the file.
   2. Starting at the beginning of the file, go to each printout in turn, copy
      the suggestion in place of `squeeze_simp`.
   3. after all the suggestions were applied, search and replace `squeeze_simp` with
      `simp` to remove the occurrences of `squeeze_simp` that did not produce a suggestion.

Known limitation(s):
  * in cases where `squeeze_simp` is used after a `;` (e.g. `cases x; squeeze_simp`),
    `squeeze_simp` will produce as many suggestions as the number of goals it is applied to.
    It is likely that none of the suggestion is a good replacement but they can all be
    combined by concatenating their list of lemmas. `squeeze_scope` can be used to
    combine the suggestions: `by squeeze_scope { cases x; squeeze_simp }`
  * sometimes, `simp` lemmas are also `_refl_lemma` and they can be used without appearing in the
    resulting proof. `squeeze_simp` won't know to try that lemma unless it is called as `squeeze_simp?`

-/
/-- see `squeeze_simp` -/
/-- `squeeze_dsimp` behaves like `dsimp` (including all its arguments)
and prints a `dsimp only` invocation to skip the search through the
`simp` lemma list. See the doc string of `squeeze_simp` for examples.
 -/
end interactive

end tactic


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

/-!
# `generalize_proofs`

A simple tactic to find and replace all occurrences of proof terms in the
context and goal with new variables.
-/

open interactive interactive.types lean.parser

namespace tactic

private meta def collect_proofs_in :
  expr → list expr → list name × list expr → tactic (list name × list expr)
| e ctx (ns, hs) :=
let go (tac : list name × list expr → tactic (list name × list expr)) :
  tactic (list name × list expr) :=
do t ← infer_type e,
   mcond (is_prop t) (do
     first (hs.map $ λ h, do
       t' ← infer_type h,
       is_def_eq t t',
       g ← target,
       change $ g.replace (λ a n, if a = e then some h else none),
       return (ns, hs)) <|>
     (let (n, ns) := (match ns with
        | [] := (`_x, [])
        | (n :: ns) := (n, ns)
        end : name × list name) in
      do generalize e n,
         h ← intro n,
         return (ns, h::hs)) <|> return (ns, hs)) (tac (ns, hs)) in
match e with
| (expr.const _ _)   := go return
| (expr.local_const _ _ _ _) := do t ← infer_type e, collect_proofs_in t ctx (ns, hs)
| (expr.mvar _ _ _)  := do t ← infer_type e, collect_proofs_in t ctx (ns, hs)
| (expr.app f x)     :=
  go (λ nh, collect_proofs_in f ctx nh >>= collect_proofs_in x ctx)
| (expr.lam n b d e) :=
  go (λ nh, do
    nh ← collect_proofs_in d ctx nh,
    var ← mk_local' n b d,
    collect_proofs_in (expr.instantiate_var e var) (var::ctx) nh)
| (expr.pi n b d e) := do
  nh ← collect_proofs_in d ctx (ns, hs),
  var ← mk_local' n b d,
  collect_proofs_in (expr.instantiate_var e var) (var::ctx) nh
| (expr.elet n t d e) :=
  go (λ nh, do
    nh ← collect_proofs_in t ctx nh,
    nh ← collect_proofs_in d ctx nh,
    collect_proofs_in (expr.instantiate_var e d) ctx nh)
| (expr.macro m l) :=
  go (λ nh, mfoldl (λ x e, collect_proofs_in e ctx x) nh l)
| _                  := return (ns, hs)
end

/-- Generalize proofs in the goal, naming them with the provided list. -/
meta def generalize_proofs (ns : list name) (loc : interactive.loc) : tactic unit :=
do intros_dep,
  hs ← local_context >>= mfilter is_proof,
  n ← loc.get_locals >>= revert_lst,
  t ← target,
  collect_proofs_in t [] (ns, hs),
  intron n <|> (intros $> ())

local postfix *:9001 := many

namespace interactive
/-- Generalize proofs in the goal, naming them with the provided list.

For example:
```lean
example : list.nth_le [1, 2] 1 dec_trivial = 2 :=
begin
  -- ⊢ [1, 2].nth_le 1 _ = 2
  generalize_proofs h,
  -- h : 1 < [1, 2].length
  -- ⊢ [1, 2].nth_le 1 h = 2
end
```
-/
meta def generalize_proofs : parse ident_* → parse location → tactic unit :=
tactic.generalize_proofs
end interactive

add_tactic_doc
{ name       := "generalize_proofs",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize_proofs],
  tags       := ["context management"] }

end tactic


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import algebra.group_power.lemmas
import category_theory.pi.basic
import category_theory.shift.basic
import category_theory.concrete_category.basic

/-!
# The category of graded objects

For any type `β`, a `β`-graded object over some category `C` is just
a function `β → C` into the objects of `C`.
We put the "pointwise" category structure on these, as the non-dependent specialization of
`category_theory.pi`.

We describe the `comap` functors obtained by precomposing with functions `β → γ`.

As a consequence a fixed element (e.g. `1`) in an additive group `β` provides a shift
functor on `β`-graded objects

When `C` has coproducts we construct the `total` functor `graded_object β C ⥤ C`,
show that it is faithful, and deduce that when `C` is concrete so is `graded_object β C`.
-/

open category_theory.pi
open category_theory.limits

namespace category_theory

universes w v u

/-- A type synonym for `β → C`, used for `β`-graded objects in a category `C`. -/
def graded_object (β : Type w) (C : Type u) : Type (max w u) := β → C

-- Satisfying the inhabited linter...
instance inhabited_graded_object (β : Type w) (C : Type u) [inhabited C] :
  inhabited (graded_object β C) :=
⟨λ b, inhabited.default⟩

/--
A type synonym for `β → C`, used for `β`-graded objects in a category `C`
with a shift functor given by translation by `s`.
-/
@[nolint unused_arguments] -- `s` is here to distinguish type synonyms asking for different shifts
abbreviation graded_object_with_shift {β : Type w} [add_comm_group β] (s : β) (C : Type u) :
  Type (max w u) := graded_object β C

namespace graded_object

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

instance category_of_graded_objects (β : Type w) : category.{max w v} (graded_object β C) :=
category_theory.pi (λ _, C)

/-- The projection of a graded object to its `i`-th component. -/
@[simps] def eval {β : Type w} (b : β) : graded_object β C ⥤ C :=
{ obj := λ X, X b,
  map := λ X Y f, f b, }

section
variable (C)

/--
The natural isomorphism comparing between
pulling back along two propositionally equal functions.
-/
@[simps]
def comap_eq {β γ : Type w} {f g : β → γ} (h : f = g) : comap (λ _, C) f ≅ comap (λ _, C) g :=
{ hom := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end },
  inv := { app := λ X b, eq_to_hom begin dsimp [comap], subst h, end }, }

lemma comap_eq_symm {β γ : Type w} {f g : β → γ} (h : f = g) :
  comap_eq C h.symm = (comap_eq C h).symm :=
by tidy

lemma comap_eq_trans {β γ : Type w} {f g h : β → γ} (k : f = g) (l : g = h) :
  comap_eq C (k.trans l) = comap_eq C k ≪≫ comap_eq C l :=
begin
  ext X b,
  simp,
end

@[simp] lemma eq_to_hom_apply {β : Type w} {X Y : Π b : β, C} (h : X = Y) (b : β) :
  (eq_to_hom h : X ⟶ Y) b = eq_to_hom (by subst h) :=
by { subst h, refl }

/--
The equivalence between β-graded objects and γ-graded objects,
given an equivalence between β and γ.
-/
@[simps]
def comap_equiv {β γ : Type w} (e : β ≃ γ) :
  (graded_object β C) ≌ (graded_object γ C) :=
{ functor := comap (λ _, C) (e.symm : γ → β),
  inverse := comap (λ _, C) (e : β → γ),
  counit_iso := (comap_comp (λ _, C) _ _).trans (comap_eq C (by { ext, simp } )),
  unit_iso := (comap_eq C (by { ext, simp } )).trans (comap_comp _ _ _).symm,
  functor_unit_iso_comp' := λ X, by { ext b, dsimp, simp, }, }  -- See note [dsimp, simp].

end

instance has_shift {β : Type*} [add_comm_group β] (s : β) :
  has_shift (graded_object_with_shift s C) ℤ :=
has_shift_mk _ _
{ F := λ n, comap (λ _, C) $ λ (b : β), b + n • s,
  zero := comap_eq C (by { ext, simp }) ≪≫ comap_id β (λ _, C),
  add := λ m n,  comap_eq C (by { ext, simp [add_zsmul, add_comm], }) ≪≫
    (comap_comp _ _ _).symm,
  assoc_hom_app := λ m₁ m₂ m₃ X, by { ext, dsimp, simp, },
  zero_add_hom_app := λ n X, by { ext, dsimp, simpa, },
  add_zero_hom_app := λ n X, by { ext, dsimp, simpa, }, }

@[simp] lemma shift_functor_obj_apply {β : Type*} [add_comm_group β]
  (s : β) (X : β → C) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).obj X t = X (t + n • s) :=
rfl

@[simp] lemma shift_functor_map_apply {β : Type*} [add_comm_group β] (s : β)
  {X Y : graded_object_with_shift s C} (f : X ⟶ Y) (t : β) (n : ℤ) :
  (shift_functor (graded_object_with_shift s C) n).map f t = f (t + n • s) :=
rfl

instance has_zero_morphisms [has_zero_morphisms C] (β : Type w) :
  has_zero_morphisms.{max w v} (graded_object β C) :=
{ has_zero := λ X Y,
  { zero := λ b, 0 } }

@[simp]
lemma zero_apply [has_zero_morphisms C] (β : Type w) (X Y : graded_object β C) (b : β) :
  (0 : X ⟶ Y) b = 0 := rfl

section
open_locale zero_object

instance has_zero_object [has_zero_object C] [has_zero_morphisms C] (β : Type w) :
  has_zero_object.{max w v} (graded_object β C) :=
by { refine ⟨⟨λ b, 0, λ X, ⟨⟨⟨λ b, 0⟩, λ f, _⟩⟩, λ X, ⟨⟨⟨λ b, 0⟩, λ f, _⟩⟩⟩⟩; ext, }
end

end graded_object

namespace graded_object
-- The universes get a little hairy here, so we restrict the universe level for the grading to 0.
-- Since we're typically interested in grading by ℤ or a finite group, this should be okay.
-- If you're grading by things in higher universes, have fun!
variables (β : Type)
variables (C : Type u) [category.{v} C]
variables [has_coproducts.{0} C]

section
local attribute [tidy] tactic.discrete_cases

/--
The total object of a graded object is the coproduct of the graded components.
-/
noncomputable def total : graded_object β C ⥤ C :=
{ obj := λ X, ∐ (λ i : β, X i),
  map := λ X Y f, limits.sigma.map (λ i, f i) }.

end

variables [has_zero_morphisms C]

/--
The `total` functor taking a graded object to the coproduct of its graded components is faithful.
To prove this, we need to know that the coprojections into the coproduct are monomorphisms,
which follows from the fact we have zero morphisms and decidable equality for the grading.
-/
instance : faithful (total β C) :=
{ map_injective' := λ X Y f g w,
  begin
    classical,
    ext i,
    replace w := sigma.ι (λ i : β, X i) i ≫= w,
    erw [colimit.ι_map, colimit.ι_map] at w,
    simp at *,
    exact mono.right_cancellation _ _ w,
  end }

end graded_object

namespace graded_object

noncomputable theory

variables (β : Type)
variables (C : Type (u+1)) [large_category C] [concrete_category C]
  [has_coproducts.{0} C] [has_zero_morphisms C]

instance : concrete_category (graded_object β C) :=
{ forget := total β C ⋙ forget C }

instance : has_forget₂ (graded_object β C) C :=
{ forget₂ := total β C }

end graded_object

end category_theory


/-
---
title: "Metaprogramming in Lean 4"
author: [Arthur Paulino, Damiano Testa, Edward Ayers, Evgenia Karunus,
        Henrik Böving, Jannis Limperg, Siddhartha Gadgil, Siddharth Bhat]
# abusing this field just because the template puts it at a decent right-sized spot
date: "Formatted for PDF by Julian Berman using [Pascal Wagler's Template](https://github.com/Wandmalfarbe/pandoc-latex-template)"
mainfont: "DejaVu Serif"
monofont: "DejaVu Sans Mono"
book: true
header-right: "."
titlepage: true
titlepage-color: "FFFFFF"
titlepage-text-color: "5F5F5F"
titlepage-rule-color: "435488"
keywords: [Lean, theorem proving, mathematics, math, maths, tutorial]
...
-/


/-
Copyright (c) 2020 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.logic.basic
import Mathlib.data.fintype.basic
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Derive handler for `fintype` instances

This file introduces a derive handler to automatically generate `fintype`
instances for structures and inductives.

## Implementation notes

To construct a fintype instance, we need 3 things:

  1. A list `l` of elements
  2. A proof that `l` has no duplicates
  3. A proof that every element in the type is in `l`

Now fintype is defined as a finset which enumerates all elements, so steps (1) and (2) are
bundled together. It is possible to use finset operations that remove duplicates to avoid the need
to prove (2), but this adds unnecessary functions to the constructed term, which makes it more
expensive to compute the list, and it also adds a dependence on decidable equality for the type,
which we want to avoid.

Because we will rely on fintype instances for constructor arguments, we can't actually build a list
directly, so (1) and (2) are necessarily somewhat intertwined. The inductive types we will be
proving instances for look something like this:

```
@[derive fintype]
inductive foo
| zero : foo
| one : bool → foo
| two : ∀ x : fin 3, bar x → foo
```

The list of elements that we generate is
```
{foo.zero}
∪ (finset.univ : bool).map (λ b, finset.one b)
∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
except that instead of `∪`, that is `finset.union`, we use `finset.disj_union` which doesn't
require any deduplication, but does require a proof that the two parts of the union are disjoint.
We use `finset.cons` to append singletons like `foo.zero`.

The proofs of disjointness would be somewhat expensive since there are quadratically many of them,
so instead we use a "discriminant" function. Essentially, we define
```
def foo.enum : foo → ℕ
| foo.zero := 0
| (foo.one _) := 1
| (foo.two _ _) := 2
```
and now the existence of this function implies that foo.zero is not foo.two and so on because they
map to different natural numbers. We can prove that sets of natural numbers are mutually disjoint
more easily because they have a linear order: `0 < 1 < 2` so `0 ≠ 2`.

To package this argument up, we define `finset_above foo foo.enum n` to be a finset `s` together
with a proof that all elements `a ∈ s` have `n ≤ enum a`. Now we only have to prove that
`enum foo.zero = 0`, `enum (foo.one _) = 1`, etc. (linearly many proofs, all `rfl`) in order to
prove that all variants are mutually distinct.

We mirror the `finset.cons` and `finset.disj_union` functions into `finset_above.cons` and
`finset_above.union`, and this forms the main part of the finset construction.

This only handles distinguishing variants of a finset. Now we must enumerate the elements of a
variant, for example `{foo.one ff, foo.one tt}`, while at the same time proving that all these
elements have discriminant `1` in this case. To do that, we use the `finset_in` type, which
is a finset satisfying a property `P`, here `λ a, foo.enum a = 1`.

We could use `finset.bind` many times to construct the finset but it turns out to be somewhat
complicated to get good side goals for a naturally nodup version of `finset.bind` in the same way
as we did with `finset.cons` and `finset.union`. Instead, we tuple up all arguments into one type,
leveraging the `fintype` instance on `psigma`, and then define a map from this type to the
inductive type that untuples them and applies the constructor. The injectivity property of the
constructor ensures that this function is injective, so we can use `finset.map` to apply it. This
is the content of the constructor `finset_in.mk`.

That completes the proofs of (1) and (2). To prove (3), we perform one case analysis over the
inductive type, proving theorems like
```
foo.one a ∈ {foo.zero}
  ∪ (finset.univ : bool).map (λ b, finset.one b)
  ∪ (finset.univ : Σ' x : fin 3, bar x).map (λ ⟨x, y⟩, finset.two x y)
```
by seeking to the relevant disjunct and then supplying the constructor arguments. This part of the
proof is quadratic, but quite simple. (We could do it in `O(n log n)` if we used a balanced tree
for the unions.)

The tactics perform the following parts of this proof scheme:
* `mk_sigma` constructs the type `Γ` in `finset_in.mk`
* `mk_sigma_elim` constructs the function `f` in `finset_in.mk`
* `mk_sigma_elim_inj` proves that `f` is injective
* `mk_sigma_elim_eq` proves that `∀ a, enum (f a) = k`
* `mk_finset` constructs the finset `S = {foo.zero} ∪ ...` by recursion on the variants
* `mk_finset_total` constructs the proof `|- foo.zero ∈ S; |- foo.one a ∈ S; |- foo.two a b ∈ S`
  by recursion on the subgoals coming out of the initial `cases`
* `mk_fintype_instance` puts it all together to produce a proof of `fintype foo`.
  The construction of `foo.enum` is also done in this function.

-/

namespace derive_fintype

/-- A step in the construction of `finset.univ` for a finite inductive type.
We will set `enum` to the discriminant of the inductive type, so a `finset_above`
represents a finset that enumerates all elements in a tail of the constructor list. -/
def finset_above (α : Type u_1) (enum : α → ℕ) (n : ℕ) :=
  Subtype fun (s : finset α) => ∀ (x : α), x ∈ s → n ≤ enum x

/-- Construct a fintype instance from a completed `finset_above`. -/
def mk_fintype {α : Type u_1} (enum : α → ℕ) (s : finset_above α enum 0) (H : ∀ (x : α), x ∈ subtype.val s) : fintype α :=
  fintype.mk (subtype.val s) H

/-- This is the case for a simple variant (no arguments) in an inductive type. -/
def finset_above.cons {α : Type u_1} {enum : α → ℕ} (n : ℕ) (a : α) (h : enum a = n) (s : finset_above α enum (n + 1)) : finset_above α enum n :=
  { val := finset.cons a (subtype.val s) sorry, property := sorry }

theorem finset_above.mem_cons_self {α : Type u_1} {enum : α → ℕ} {n : ℕ} {a : α} {h : enum a = n} {s : finset_above α enum (n + 1)} : a ∈ subtype.val (finset_above.cons n a h s) :=
  multiset.mem_cons_self a (finset.val (subtype.val s))

theorem finset_above.mem_cons_of_mem {α : Type u_1} {enum : α → ℕ} {n : ℕ} {a : α} {h : enum a = n} {s : finset_above α enum (n + 1)} {b : α} : b ∈ subtype.val s → b ∈ subtype.val (finset_above.cons n a h s) :=
  multiset.mem_cons_of_mem

/-- The base case is when we run out of variants; we just put an empty finset at the end. -/
def finset_above.nil {α : Type u_1} {enum : α → ℕ} (n : ℕ) : finset_above α enum n :=
  { val := ∅, property := sorry }

protected instance finset_above.inhabited (α : Type u_1) (enum : α → ℕ) (n : ℕ) : Inhabited (finset_above α enum n) :=
  { default := finset_above.nil n }

/-- This is a finset covering a nontrivial variant (with one or more constructor arguments).
The property `P` here is `λ a, enum a = n` where `n` is the discriminant for the current
variant. -/
def finset_in {α : Type u_1} (P : α → Prop) :=
  Subtype fun (s : finset α) => ∀ (x : α), x ∈ s → P x

/-- To construct the finset, we use an injective map from the type `Γ`, which will be the
sigma over all constructor arguments. We use sigma instances and existing fintype instances
to prove that `Γ` is a fintype, and construct the function `f` that maps `⟨a, b, c, ...⟩`
to `C_n a b c ...` where `C_n` is the nth constructor, and `mem` asserts
`enum (C_n a b c ...) = n`. -/
def finset_in.mk {α : Type u_1} {P : α → Prop} (Γ : Type u_2) [fintype Γ] (f : Γ → α) (inj : function.injective f) (mem : ∀ (x : Γ), P (f x)) : finset_in P :=
  { val := finset.map (function.embedding.mk f inj) finset.univ, property := sorry }

theorem finset_in.mem_mk {α : Type u_1} {P : α → Prop} {Γ : Type u_2} {s : fintype Γ} {f : Γ → α} {inj : function.injective f} {mem : ∀ (x : Γ), P (f x)} {a : α} (b : Γ) (H : f b = a) : a ∈ subtype.val (finset_in.mk Γ f inj mem) :=
  iff.mpr finset.mem_map (Exists.intro b (Exists.intro (finset.mem_univ b) H))

/-- For nontrivial variants, we split the constructor list into a `finset_in` component for the
current constructor and a `finset_above` for the rest. -/
def finset_above.union {α : Type u_1} {enum : α → ℕ} (n : ℕ) (s : finset_in fun (a : α) => enum a = n) (t : finset_above α enum (n + 1)) : finset_above α enum n :=
  { val := finset.disj_union (subtype.val s) (subtype.val t) sorry, property := sorry }

theorem finset_above.mem_union_left {α : Type u_1} {enum : α → ℕ} {n : ℕ} {s : finset_in fun (a : α) => enum a = n} {t : finset_above α enum (n + 1)} {a : α} (H : a ∈ subtype.val s) : a ∈ subtype.val (finset_above.union n s t) :=
  iff.mpr multiset.mem_add (Or.inl H)

theorem finset_above.mem_union_right {α : Type u_1} {enum : α → ℕ} {n : ℕ} {s : finset_in fun (a : α) => enum a = n} {t : finset_above α enum (n + 1)} {a : α} (H : a ∈ subtype.val t) : a ∈ subtype.val (finset_above.union n s t) :=
  iff.mpr multiset.mem_add (Or.inr H)


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

/-!
# The category of bipointed types

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

@[simp] lemma coe_of {X : Type*} (to_prod : X × X) : ↥(of to_prod) = X := rfl

alias of ← prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Swaps the pointed elements of a bipointed type. `prod.swap` as a functor. -/
@[simps] def swap : Bipointed ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.to_prod.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

/-- The functor from `Pointed` to `Bipointed` which bipoints the point. -/
def Pointed_to_Bipointed : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.point, X.point⟩, map := λ X Y f, ⟨f.to_fun, f.map_point, f.map_point⟩ }

/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, none⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Bipointed_fst_comp_swap :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp_swap :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- `Bipointed_to_Pointed_fst` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_fst :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_fst ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- `Bipointed_to_Pointed_snd` is inverse to `Pointed_to_Bipointed`. -/
@[simps] def Pointed_to_Bipointed_comp_Bipointed_to_Pointed_snd :
  Pointed_to_Bipointed ⋙ Bipointed_to_Pointed_snd ≅ 𝟭 _ :=
nat_iso.of_components (λ X, { hom := ⟨id, rfl⟩, inv := ⟨id, rfl⟩ }) $ λ X Y f, rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.2 f.to_fun, f.map_point, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.1 f.to_fun, rfl, f.map_point⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.applicative
import data.list.forall2
import data.set.functor

/-!
# Traversable instances

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

This file provides instances of `traversable` for types from the core library: `option`, `list` and
`sum`.
-/

universes u v

section option

open functor

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]
variables [is_lawful_applicative F] [is_lawful_applicative G]

lemma option.id_traverse {α} (x : option α) : option.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
lemma option.comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : option α) :
  option.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (option.traverse f <$> option.traverse g x) :=
by cases x; simp! with functor_norm; refl

lemma option.traverse_eq_map_id {α β} (f : α → β) (x : option α) :
  traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by cases x; refl

variable (η : applicative_transformation F G)

lemma option.naturality {α β} (f : α → F β) (x : option α) :
  η (option.traverse f x) = option.traverse (@η _ ∘ f) x :=
by cases x with x; simp! [*] with functor_norm

end option

instance : is_lawful_traversable option :=
{ id_traverse := @option.id_traverse,
  comp_traverse := @option.comp_traverse,
  traverse_eq_map_id := @option.traverse_eq_map_id,
  naturality := @option.naturality,
  .. option.is_lawful_monad }

namespace list

variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

section
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor list

protected

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : list α) :
  list.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (list.traverse f <$> list.traverse g x) :=
by induction x; simp! * with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : list α) :
  list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : list α) :
  η (list.traverse f x) = list.traverse (@η _ ∘ f) x :=
by induction x; simp! * with functor_norm
open nat

instance : is_lawful_traversable.{u} list :=
{ id_traverse := @list.id_traverse,
  comp_traverse := @list.comp_traverse,
  traverse_eq_map_id := @list.traverse_eq_map_id,
  naturality := @list.naturality,
  .. list.is_lawful_monad }
end

section traverse
variables {α' β' : Type u} (f : α' → F β')

@[simp] lemma traverse_nil : traverse f ([] : list α') = (pure [] : F (list β')) := rfl

@[simp] lemma traverse_cons (a : α') (l : list α') :
  traverse f (a :: l) = (::) <$> f a <*> traverse f l := rfl

variables [is_lawful_applicative F]

@[simp] lemma traverse_append :
  ∀ (as bs : list α'), traverse f (as ++ bs) = (++) <$> traverse f as <*> traverse f bs
| [] bs :=
  have has_append.append ([] : list β') = id, by funext; refl,
  by simp [this] with functor_norm
| (a :: as) bs := by simp [traverse_append as bs] with functor_norm; congr

lemma mem_traverse {f : α' → set β'} :
  ∀(l : list α') (n : list β'), n ∈ traverse f l ↔ forall₂ (λb a, b ∈ f a) n l
| []      []      := by simp
| (a::as) []      := by simp
| []      (b::bs) := by simp
| (a::as) (b::bs) := by simp [mem_traverse as bs]

end traverse

end list

namespace sum

section traverse
variables {σ : Type u}
variables {F G : Type u → Type u}
variables [applicative F] [applicative G]

open applicative functor
open list (cons)

protected lemma traverse_map {α β γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
  sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; refl

variables [is_lawful_applicative F] [is_lawful_applicative G]

protected lemma id_traverse {σ α} (x : σ ⊕ α) : sum.traverse id.mk x = x :=
by cases x; refl

@[nolint unused_arguments]
protected lemma comp_traverse {α β γ} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
  sum.traverse (comp.mk ∘ (<$>) f ∘ g) x =
  comp.mk (sum.traverse f <$> sum.traverse g x) :=
by cases x; simp! [sum.traverse,map_id] with functor_norm; refl

protected lemma traverse_eq_map_id {α β} (f : α → β) (x : σ ⊕ α) :
  sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
by induction x; simp! * with functor_norm; refl

protected lemma map_traverse {α β γ} (g : α → G β) (f : β → γ) (x : σ ⊕ α) :
  (<$>) f <$> sum.traverse g x = sum.traverse ((<$>) f ∘ g) x :=
by cases x; simp [sum.traverse, id_map] with functor_norm; congr; refl

variable (η : applicative_transformation F G)

protected lemma naturality {α β} (f : α → F β) (x : σ ⊕ α) :
  η (sum.traverse f x) = sum.traverse (@η _ ∘ f) x :=
by cases x; simp! [sum.traverse] with functor_norm

end traverse

instance {σ : Type u} : is_lawful_traversable.{u} (sum σ) :=
{ id_traverse := @sum.id_traverse σ,
  comp_traverse := @sum.comp_traverse σ,
  traverse_eq_map_id := @sum.traverse_eq_map_id σ,
  naturality := @sum.naturality σ,
  .. sum.is_lawful_monad }

end sum


example (p q r : Prop) (hp : p) (hq : q) (hr : r) : p ∧ ((p ∧ q) ∧ r) ∧ (q ∧ r ∧ p) :=
  by repeat { any_goals { split <|> assumption} }


import tactic --hide

/-Lemma
An even more nested implications
-/
lemma lemma_8 (P Q R : Prop) : ((P → Q) → R) → ((Q → R) → P) → ((R → P) → Q) → P :=
begin
  intros h1 h2 h3,
  apply h2,
  intro hQ,
  apply h1,
  intro hP,
  exact hQ,

end


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

import tidy.timing

open tactic

private lemma f : 1 = 1 :=
begin
    (time_tactic skip) >>= trace,
    simp
end


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4 u_5 u_6

namespace Mathlib

/-!
# Extra facts about `prod`

This file defines `prod.swap : α × β → β × α` and proves various simple lemmas about `prod`.
-/

@[simp] theorem prod_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) (p : α × β) : prod.map f g p = (f (prod.fst p), g (prod.snd p)) :=
  rfl

namespace prod

@[simp] theorem forall {α : Type u_1} {β : Type u_2} {p : α × β → Prop} : (∀ (x : α × β), p x) ↔ ∀ (a : α) (b : β), p (a, b) := sorry

@[simp] theorem exists {α : Type u_1} {β : Type u_2} {p : α × β → Prop} : (∃ (x : α × β), p x) ↔ ∃ (a : α), ∃ (b : β), p (a, b) := sorry

theorem forall' {α : Type u_1} {β : Type u_2} {p : α → β → Prop} : (∀ (x : α × β), p (fst x) (snd x)) ↔ ∀ (a : α) (b : β), p a b :=
  forall

theorem exists' {α : Type u_1} {β : Type u_2} {p : α → β → Prop} : (∃ (x : α × β), p (fst x) (snd x)) ↔ ∃ (a : α), ∃ (b : β), p a b :=
  exists

@[simp] theorem map_mk {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) (a : α) (b : β) : map f g (a, b) = (f a, g b) :=
  rfl

theorem map_fst {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) (p : α × β) : fst (map f g p) = f (fst p) :=
  rfl

theorem map_snd {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) (p : α × β) : snd (map f g p) = g (snd p) :=
  rfl

theorem map_fst' {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) : fst ∘ map f g = f ∘ fst :=
  funext (map_fst f g)

theorem map_snd' {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} (f : α → γ) (g : β → δ) : snd ∘ map f g = g ∘ snd :=
  funext (map_snd f g)

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions.
-/
theorem map_comp_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {ε : Type u_5} {ζ : Type u_6} (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) : map g g' ∘ map f f' = map (g ∘ f) (g' ∘ f') :=
  rfl

/--
Composing a `prod.map` with another `prod.map` is equal to
a single `prod.map` of composed functions, fully applied.
-/
theorem map_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {ε : Type u_5} {ζ : Type u_6} (f : α → β) (f' : γ → δ) (g : β → ε) (g' : δ → ζ) (x : α × γ) : map g g' (map f f' x) = map (g ∘ f) (g' ∘ f') x :=
  rfl

@[simp] theorem mk.inj_iff {α : Type u_1} {β : Type u_2} {a₁ : α} {a₂ : α} {b₁ : β} {b₂ : β} : (a₁, b₁) = (a₂, b₂) ↔ a₁ = a₂ ∧ b₁ = b₂ := sorry

theorem mk.inj_left {α : Type u_1} {β : Type u_2} (a : α) : function.injective (Prod.mk a) := sorry

theorem mk.inj_right {α : Type u_1} {β : Type u_2} (b : β) : function.injective fun (a : α) => (a, b) := sorry

theorem ext_iff {α : Type u_1} {β : Type u_2} {p : α × β} {q : α × β} : p = q ↔ fst p = fst q ∧ snd p = snd q := sorry

theorem ext {α : Type u_1} {β : Type u_2} {p : α × β} {q : α × β} (h₁ : fst p = fst q) (h₂ : snd p = snd q) : p = q :=
  iff.mpr ext_iff { left := h₁, right := h₂ }

theorem map_def {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {f : α → γ} {g : β → δ} : map f g = fun (p : α × β) => (f (fst p), g (snd p)) :=
  funext fun (p : α × β) => ext (map_fst f g p) (map_snd f g p)

theorem id_prod {α : Type u_1} : (fun (p : α × α) => (fst p, snd p)) = id := sorry

theorem fst_surjective {α : Type u_1} {β : Type u_2} [h : Nonempty β] : function.surjective fst :=
  fun (x : α) => nonempty.elim h fun (y : β) => Exists.intro (x, y) rfl

theorem snd_surjective {α : Type u_1} {β : Type u_2} [h : Nonempty α] : function.surjective snd :=
  fun (y : β) => nonempty.elim h fun (x : α) => Exists.intro (x, y) rfl

theorem fst_injective {α : Type u_1} {β : Type u_2} [subsingleton β] : function.injective fst :=
  fun (x y : α × β) (h : fst x = fst y) => ext h (subsingleton.elim (snd x) (snd y))

theorem snd_injective {α : Type u_1} {β : Type u_2} [subsingleton α] : function.injective snd :=
  fun (x y : α × β) (h : snd x = snd y) => ext (subsingleton.elim (fst x) (fst y)) h

/-- Swap the factors of a product. `swap (a, b) = (b, a)` -/
def swap {α : Type u_1} {β : Type u_2} : α × β → β × α :=
  fun (p : α × β) => (snd p, fst p)

@[simp] theorem swap_swap {α : Type u_1} {β : Type u_2} (x : α × β) : swap (swap x) = x :=
  cases_on x fun (x_fst : α) (x_snd : β) => idRhs (swap (swap (x_fst, x_snd)) = swap (swap (x_fst, x_snd))) rfl

@[simp] theorem fst_swap {α : Type u_1} {β : Type u_2} {p : α × β} : fst (swap p) = snd p :=
  rfl

@[simp] theorem snd_swap {α : Type u_1} {β : Type u_2} {p : α × β} : snd (swap p) = fst p :=
  rfl

@[simp] theorem swap_prod_mk {α : Type u_1} {β : Type u_2} {a : α} {b : β} : swap (a, b) = (b, a) :=
  rfl

@[simp] theorem swap_swap_eq {α : Type u_1} {β : Type u_2} : swap ∘ swap = id :=
  funext swap_swap

@[simp] theorem swap_left_inverse {α : Type u_1} {β : Type u_2} : function.left_inverse swap swap :=
  swap_swap

@[simp] theorem swap_right_inverse {α : Type u_1} {β : Type u_2} : function.right_inverse swap swap :=
  swap_swap

theorem swap_injective {α : Type u_1} {β : Type u_2} : function.injective swap :=
  function.left_inverse.injective swap_left_inverse

theorem swap_surjective {α : Type u_1} {β : Type u_2} : function.surjective swap :=
  function.left_inverse.surjective swap_left_inverse

theorem swap_bijective {α : Type u_1} {β : Type u_2} : function.bijective swap :=
  { left := swap_injective, right := swap_surjective }

@[simp] theorem swap_inj {α : Type u_1} {β : Type u_2} {p : α × β} {q : α × β} : swap p = swap q ↔ p = q :=
  function.injective.eq_iff swap_injective

theorem eq_iff_fst_eq_snd_eq {α : Type u_1} {β : Type u_2} {p : α × β} {q : α × β} : p = q ↔ fst p = fst q ∧ snd p = snd q := sorry

theorem fst_eq_iff {α : Type u_1} {β : Type u_2} {p : α × β} {x : α} : fst p = x ↔ p = (x, snd p) := sorry

theorem snd_eq_iff {α : Type u_1} {β : Type u_2} {p : α × β} {x : β} : snd p = x ↔ p = (fst p, x) := sorry

theorem lex_def {α : Type u_1} {β : Type u_2} (r : α → α → Prop) (s : β → β → Prop) {p : α × β} {q : α × β} : lex r s p q ↔ r (fst p) (fst q) ∨ fst p = fst q ∧ s (snd p) (snd q) := sorry

protected instance lex.decidable {α : Type u_1} {β : Type u_2} [DecidableEq α] (r : α → α → Prop) (s : β → β → Prop) [DecidableRel r] [DecidableRel s] : DecidableRel (lex r s) :=
  fun (p q : α × β) => decidable_of_decidable_of_iff or.decidable sorry

end prod

theorem function.injective.prod_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {f : α → γ} {g : β → δ} (hf : function.injective f) (hg : function.injective g) : function.injective (prod.map f g) :=
  fun (x y : α × β) (h : prod.map f g x = prod.map f g y) =>
    prod.ext (hf (and.left (iff.mp prod.ext_iff h))) (hg (and.right (iff.mp prod.ext_iff h)))

theorem function.surjective.prod_map {α : Type u_1} {β : Type u_2} {γ : Type u_3} {δ : Type u_4} {f : α → γ} {g : β → δ} (hf : function.surjective f) (hg : function.surjective g) : function.surjective (prod.map f g) := sorry


/-
Copyright (c) 2020 Bhavik Mehta, Edward Ayers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Bhavik Mehta, Edward Ayers
-/

import category_theory.limits.shapes
import category_theory.limits.preserves.limits
import category_theory.limits.over
import category_theory.limits.shapes.constructions.over
import tactic

/-!
# Pullbacks

Many, many lemmas to work with pullbacks.
-/
open category_theory category_theory.category category_theory.limits

noncomputable theory
universes u v
variables {C : Type u} [category.{v} C]
variables {J : Type v} [small_category J]

variables {W X Y Z : C} {f : X ⟶ Z} {g : Y ⟶ Z}

/-- A supremely useful structure for elementary topos theory. -/
structure has_pullback_top (left : W ⟶ Y) (bottom : Y ⟶ Z) (right : X ⟶ Z) :=
(top : W ⟶ X)
(comm : top ≫ right = left ≫ bottom)
(is_pb : is_limit (pullback_cone.mk _ _ comm))

attribute [reassoc] has_pullback_top.comm

instance subsingleton_hpb (left : W ⟶ Y) (bottom : Y ⟶ Z) (right : X ⟶ Z) [mono right] :
  subsingleton (has_pullback_top left bottom right) :=
⟨begin
  intros P Q,
  cases P,
  cases Q,
  congr,
  rw ← cancel_mono right,
  rw P_comm, rw Q_comm
end⟩

def has_pullback_top_of_is_pb {U V W X : C}
  {f : U ⟶ V} {g : V ⟶ W} {h : U ⟶ X} {k : X ⟶ W}
  {comm : f ≫ g = h ≫ k}
  (pb : is_limit (pullback_cone.mk _ _ comm)) :
  has_pullback_top h k g :=
{ top := f,
  comm := comm,
  is_pb := pb }

def is_limit.mk' (t : pullback_cone f g)
  (create : Π (s : pullback_cone f g), {l : s.X ⟶ t.X // l ≫ t.fst = s.fst ∧ l ≫ t.snd = s.snd ∧ ∀ {m : s.X ⟶ t.X}, m ≫ t.fst = s.fst → m ≫ t.snd = s.snd → m = l}) :
is_limit t :=
pullback_cone.is_limit_aux' t create

def is_limit.mk'' (t : pullback_cone f g) [mono f]
  (create : Π (s : pullback_cone f g), {l : s.X ⟶ t.X // l ≫ t.snd = s.snd ∧ ∀ {m : s.X ⟶ t.X}, m ≫ t.fst = s.fst → m ≫ t.snd = s.snd → m = l}) :
is_limit t :=
is_limit.mk' t $
begin
  intro s,
  refine ⟨(create s).1, _, (create s).2.1, λ m m₁ m₂, (create s).2.2 m₁ m₂⟩,
  rw [← cancel_mono f, assoc, t.condition, s.condition, reassoc_of (create s).2.1]
end

def is_limit.mk''' (t : pullback_cone f g) [mono f] (q : mono t.snd)
  (create : Π (s : pullback_cone f g), {l : s.X ⟶ t.X // l ≫ t.snd = s.snd}) :
is_limit t :=
is_limit.mk' t $
begin
  intro s,
  refine ⟨(create s).1, _, (create s).2, λ m _ m₂, _⟩,
  rw [← cancel_mono f, assoc, t.condition, s.condition, reassoc_of (create s).2],
  rw [← cancel_mono t.snd, m₂, (create s).2],
end

def construct_type_pb {W X Y Z : Type u} {f : X ⟶ Z} {g : Y ⟶ Z} {h : W ⟶ _} {k} (comm : h ≫ f = k ≫ g) :
  (∀ (x : X) (y : Y), f x = g y → {t // h t = x ∧ k t = y ∧ ∀ t', h t' = x → k t' = y → t' = t}) → is_limit (pullback_cone.mk _ _ comm) :=
begin
  intro z,
  apply is_limit.mk' _ _,
  intro s,
  refine ⟨λ t, _, _, _, _⟩,
  refine (z (s.fst t) (s.snd t) (congr_fun s.condition t)).1,
  ext t,
  apply (z (s.fst t) (s.snd t) (congr_fun s.condition t)).2.1,
  ext t,
  apply (z (s.fst t) (s.snd t) (congr_fun s.condition t)).2.2.1,
  intros m m₁ m₂,
  ext t,
  apply (z (s.fst t) (s.snd t) (congr_fun s.condition t)).2.2.2,
  apply congr_fun m₁ t,
  apply congr_fun m₂ t,
end

def pullback_mono_is_mono (c : pullback_cone f g) [mono f] (t : is_limit c) : mono c.snd :=
⟨λ Z h k eq,
begin
  apply t.hom_ext,
  apply pullback_cone.equalizer_ext,
  rw [← cancel_mono f, assoc, c.condition, reassoc_of eq, assoc, c.condition],
  assumption
end⟩

def cone_is_pullback {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) [has_limit (cospan f g)] :
  is_limit (pullback_cone.mk _ _ pullback.condition : pullback_cone f g) :=
is_limit.mk' _ $ λ s,
⟨ pullback.lift _ _ s.condition,
  pullback.lift_fst _ _ _,
  pullback.lift_snd _ _ _,
  λ m m₁ m₂, pullback.hom_ext (by simpa using m₁) (by simpa using m₂) ⟩

def is_limit_as_pullback_cone_mk (s : pullback_cone f g) (t : is_limit (pullback_cone.mk s.fst s.snd s.condition)) :
  is_limit s :=
{ lift := λ c, t.lift c,
  fac' := λ c j,
  begin
    cases j,
    simp [← t.fac c none, ← s.w walking_cospan.hom.inl],
    cases j,
    exact t.fac c walking_cospan.left,
    exact t.fac c walking_cospan.right,
  end,
  uniq' := λ c m w,
  begin
    apply t.uniq,
    intro j,
    rw ← w,
    cases j,
    simp [← t.fac c none, ← s.w walking_cospan.hom.inl],
    cases j; refl,
  end }

def has_pullback_top_of_pb [has_limit (cospan f g)] :
  has_pullback_top (pullback.snd : pullback f g ⟶ Y) g f :=
{ top := pullback.fst,
  comm := pullback.condition,
  is_pb := cone_is_pullback f g }

def left_pb_to_both_pb {U V W X Y Z : C}
  (f : U ⟶ V) (g : V ⟶ W) (h : U ⟶ X) (k : V ⟶ Y) (l : W ⟶ Z) (m : X ⟶ Y) (n : Y ⟶ Z)
  (left_comm : f ≫ k = h ≫ m)
  (right_comm : g ≫ l = k ≫ n)
  (left_pb : is_limit (pullback_cone.mk f h left_comm))
  (right_pb : is_limit (pullback_cone.mk g k right_comm)) :
is_limit (pullback_cone.mk (f ≫ g) h (begin rw [assoc, right_comm, reassoc_of left_comm]end)) :=
is_limit.mk' _ $
begin
  intro s,
  let t : s.X ⟶ V := right_pb.lift (pullback_cone.mk s.fst (s.snd ≫ m) (by rw [assoc, s.condition])),
  have l_comm : t ≫ k = s.snd ≫ m := right_pb.fac _ walking_cospan.right,
  let u : s.X ⟶ U := left_pb.lift (pullback_cone.mk _ _ l_comm),
  have uf : u ≫ f = t := left_pb.fac _ walking_cospan.left,
  have tg : t ≫ g = s.fst := right_pb.fac _ walking_cospan.left,
  refine ⟨u, _, left_pb.fac _ walking_cospan.right, _⟩,
  { rw [← tg, ← uf, assoc u f g], refl },
  { intros m' m₁ m₂,
    apply left_pb.hom_ext,
    apply (pullback_cone.mk f h left_comm).equalizer_ext,
    { apply right_pb.hom_ext,
      apply (pullback_cone.mk g k right_comm).equalizer_ext,
      { erw [uf, assoc, tg], exact m₁ },
      { erw [uf, assoc, left_comm, reassoc_of m₂, l_comm] } },
    { erw [left_pb.fac _ walking_cospan.right], exact m₂ } }
end

def both_pb_to_left_pb {U V W X Y Z : C}
  (f : U ⟶ V) (g : V ⟶ W) (h : U ⟶ X) (k : V ⟶ Y) (l : W ⟶ Z) (m : X ⟶ Y) (n : Y ⟶ Z)
  (left_comm : f ≫ k = h ≫ m)
  (right_comm : g ≫ l = k ≫ n)
  (right_pb : is_limit (pullback_cone.mk g k right_comm))
  (entire_pb : is_limit (pullback_cone.mk (f ≫ g) h (begin rw [assoc, right_comm, reassoc_of left_comm] end))) :
is_limit (pullback_cone.mk f h left_comm) :=
is_limit.mk' _ $
begin
  intro s,
  let u : s.X ⟶ U := entire_pb.lift (pullback_cone.mk (s.fst ≫ g) s.snd (by rw [assoc, right_comm, s.condition_assoc])),
  have uf : u ≫ f = s.fst,
  { apply right_pb.hom_ext,
    apply (pullback_cone.mk g k right_comm).equalizer_ext,
    { rw [assoc], exact entire_pb.fac _ walking_cospan.left },
    { erw [assoc, left_comm, ← assoc, entire_pb.fac _ walking_cospan.right, s.condition], refl } },
  refine ⟨u, uf, entire_pb.fac _ walking_cospan.right, _⟩,
  { intros m' m₁ m₂,
    apply entire_pb.hom_ext,
    apply (pullback_cone.mk (f ≫ g) h _).equalizer_ext,
    { erw [reassoc_of uf, reassoc_of m₁] },
    { rwa entire_pb.fac _ walking_cospan.right } }
end

def left_hpb_right_pb_to_both_hpb {U V W X Y Z : C}
  (g : V ⟶ W) (h : U ⟶ X) (k : V ⟶ Y) (l : W ⟶ Z) (m : X ⟶ Y) (n : Y ⟶ Z)
  (left : has_pullback_top h m k)
  (right_comm : g ≫ l = k ≫ n)
  (right_pb : is_limit (pullback_cone.mk g k right_comm)) :
  has_pullback_top h (m ≫ n) l :=
{ top := left.top ≫ g,
  comm := by rw [assoc, right_comm, reassoc_of left.comm],
  is_pb := left_pb_to_both_pb left.top g h k l m n left.comm right_comm left.is_pb right_pb }

def right_both_hpb_to_left_hpb {U V W X Y Z : C}
  {h : U ⟶ X} {k : V ⟶ Y} (l : W ⟶ Z) {m : X ⟶ Y} (n : Y ⟶ Z)
  (both : has_pullback_top h (m ≫ n) l)
  (right : has_pullback_top k n l) :
  has_pullback_top h m k :=
begin
  let t : U ⟶ V := right.is_pb.lift (pullback_cone.mk both.top (h ≫ m) (by rw [assoc, both.comm])),
  refine ⟨t, right.is_pb.fac _ walking_cospan.right, _⟩,
  apply both_pb_to_left_pb t right.top h k l m n _ _ right.is_pb,
  convert both.is_pb,
  apply right.is_pb.fac _ walking_cospan.left,
end

def left_right_hpb_to_both_hpb {U V W X Y Z : C}
  {h : U ⟶ X} (k : V ⟶ Y) {l : W ⟶ Z} {m : X ⟶ Y} {n : Y ⟶ Z}
  (left : has_pullback_top h m k)
  (right : has_pullback_top k n l) :
  has_pullback_top h (m ≫ n) l :=
{ top := left.top ≫ right.top,
  comm := by rw [assoc, right.comm, reassoc_of left.comm],
  is_pb := left_pb_to_both_pb left.top right.top h k l m n left.comm right.comm left.is_pb right.is_pb }

def vpaste {U V W X Y Z : C} (f : U ⟶ V) (g : U ⟶ W) (h : V ⟶ X) (k : W ⟶ X) (l : W ⟶ Y) (m : X ⟶ Z) (n : Y ⟶ Z)
  (up_comm : f ≫ h = g ≫ k) (down_comm : k ≫ m = l ≫ n)
  (down_pb : is_limit (pullback_cone.mk _ _ down_comm))
  (up_pb : is_limit (pullback_cone.mk _ _ up_comm)) :
  is_limit (pullback_cone.mk f (g ≫ l) (by rw [reassoc_of up_comm, down_comm, assoc]) : pullback_cone (h ≫ m) n):=
is_limit.mk' _ $
begin
  intro s,
  let c' : pullback_cone m n := pullback_cone.mk (pullback_cone.fst s ≫ h) (pullback_cone.snd s) (by simp [pullback_cone.condition s]),
  let t : s.X ⟶ W := down_pb.lift c',
  have tl : t ≫ l = pullback_cone.snd s := down_pb.fac c' walking_cospan.right,
  have tk : t ≫ k = pullback_cone.fst s ≫ h := down_pb.fac c' walking_cospan.left,
  let c'' : pullback_cone h k := pullback_cone.mk (pullback_cone.fst s) t (down_pb.fac c' walking_cospan.left).symm,
  let u : s.X ⟶ U := up_pb.lift c'',
  have uf : u ≫ f = pullback_cone.fst s := up_pb.fac c'' walking_cospan.left,
  have ug : u ≫ g = t := up_pb.fac c'' walking_cospan.right,
  refine ⟨u, uf, by erw [reassoc_of ug, tl], _⟩,
  intros m' m₁ m₂,
  apply up_pb.hom_ext,
  apply (pullback_cone.mk f g up_comm).equalizer_ext,
  change m' ≫ f = u ≫ f,
  erw [m₁, uf],
  erw ug,
  apply down_pb.hom_ext,
  apply (pullback_cone.mk _ _ down_comm).equalizer_ext,
  { change (m' ≫ g) ≫ k = t ≫ k,
    slice_lhs 2 3 {rw ← up_comm},
    slice_lhs 1 2 {erw m₁},
    rw tk },
  { change (m' ≫ g) ≫ l = t ≫ l,
    erw [assoc, m₂, tl] }
end

def stretch_hpb_down {U V W X Y Z : C} (g : U ⟶ W) (h : V ⟶ X) (k : W ⟶ X) (l : W ⟶ Y) (m : X ⟶ Z) (n : Y ⟶ Z)
  (up : has_pullback_top g k h)
  (down_comm : k ≫ m = l ≫ n)
  (down_pb : is_limit (pullback_cone.mk _ _ down_comm)) :
has_pullback_top (g ≫ l) n (h ≫ m) :=
{ top := up.top,
  comm := by rw [up.comm_assoc, down_comm, assoc],
  is_pb := vpaste up.top g h k l m n up.comm down_comm down_pb up.is_pb }

def vpaste' {U V W X Y Z : C} (f : U ⟶ V) (g : U ⟶ W) (h : V ⟶ X) (k : W ⟶ X) (l : W ⟶ Y) (m : X ⟶ Z) (n : Y ⟶ Z)
  (up_comm : f ≫ h = g ≫ k) (down_comm : k ≫ m = l ≫ n)
  (down_pb : is_limit (pullback_cone.mk _ _ down_comm))
  (entire_pb : is_limit (pullback_cone.mk f (g ≫ l) (by rw [reassoc_of up_comm, down_comm, assoc]) : pullback_cone (h ≫ m) n)) :
  is_limit (pullback_cone.mk _ _ up_comm) :=
is_limit.mk' _ $
begin
  intro s,
  let c' : pullback_cone (h ≫ m) n := pullback_cone.mk (pullback_cone.fst s) (pullback_cone.snd s ≫ l) (by simp [pullback_cone.condition_assoc s, down_comm]),
  let t : s.X ⟶ U := entire_pb.lift c',
  have t₁ : t ≫ f = pullback_cone.fst s := entire_pb.fac c' walking_cospan.left,
  have t₂ : t ≫ g ≫ l = pullback_cone.snd s ≫ l := entire_pb.fac c' walking_cospan.right,
  have t₃ : t ≫ g = pullback_cone.snd s,
    apply down_pb.hom_ext,
    apply pullback_cone.equalizer_ext (pullback_cone.mk k l down_comm) _ _,
    erw [assoc, ← up_comm, reassoc_of t₁, pullback_cone.condition s], refl,
    rwa [assoc],
  refine ⟨t, t₁, t₃, _⟩,
  intros m' m₁ m₂,
  apply entire_pb.hom_ext,
  apply pullback_cone.equalizer_ext (pullback_cone.mk f (g ≫ l) _) _ _,
  exact m₁.trans t₁.symm,
  refine trans _ t₂.symm,
  erw [reassoc_of m₂]
end

-- The mono isn't strictly necessary but this version is convenient.
-- XXX: It's to ensure g is unique - the alternate solution is to take g ≫ l as one of the arguments and calculate g
def cut_hpb_up {U V W X Y Z : C} (g : U ⟶ W) (h : V ⟶ X) (k : W ⟶ X) (l : W ⟶ Y) (m : X ⟶ Z) (n : Y ⟶ Z) [mono m]
  (all : has_pullback_top (g ≫ l) n (h ≫ m))
  (down_comm : k ≫ m = l ≫ n)
  (down_pb : is_limit (pullback_cone.mk _ _ down_comm)) :
has_pullback_top g k h :=
{ top := all.top,
  comm := by rw [← cancel_mono m, assoc, all.comm, assoc, ← down_comm, assoc],
  is_pb := vpaste' _ _ _ _ _ _ _ _ _ down_pb all.is_pb }

def cut_hpb_up' {U V W X Y Z : C} (g : U ⟶ W) (h : V ⟶ X) (k : W ⟶ X) (l : W ⟶ Y) (m : X ⟶ Z) (n : Y ⟶ Z)
  (all : has_pullback_top (g ≫ l) n (h ≫ m))
  (up_comm : all.top ≫ h = g ≫ k)
  (down_comm : k ≫ m = l ≫ n)
  (down_pb : is_limit (pullback_cone.mk _ _ down_comm)) :
has_pullback_top g k h :=
{ top := all.top,
  comm := up_comm,
  is_pb := vpaste' _ _ _ _ _ _ _ _ _ down_pb all.is_pb }

-- Show
-- D × A ⟶ B × A
--   |       |
--   v       v
--   D   ⟶   B
-- is a pullback (needed in over/exponentiable_in_slice)
def pullback_prod (xy : X ⟶ Y) (Z : C) [has_binary_products.{v} C] :
  is_limit (pullback_cone.mk limits.prod.fst (limits.prod.map xy (𝟙 Z)) (limits.prod.map_fst _ _).symm) :=
is_limit.mk' _ $
begin
  intro s,
  refine ⟨prod.lift (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.snd), limit.lift_π _ _, _, _⟩,
  { change limits.prod.lift (pullback_cone.fst s) (pullback_cone.snd s ≫ limits.prod.snd) ≫
      limits.prod.map xy (𝟙 Z) = pullback_cone.snd s,
    apply prod.hom_ext,
    rw [assoc, limits.prod.map_fst, prod.lift_fst_assoc, pullback_cone.condition s],
    rw [assoc, limits.prod.map_snd, prod.lift_snd_assoc, comp_id] },
  { intros m m₁ m₂,
    apply prod.hom_ext,
    simpa using m₁,
    erw [prod.lift_snd, ← m₂, assoc, limits.prod.map_snd, comp_id] },
end

def pullback_prod' (xy : X ⟶ Y) (Z : C) [has_binary_products.{v} C] :
  is_limit (pullback_cone.mk limits.prod.snd (limits.prod.map (𝟙 Z) xy) (limits.prod.map_snd _ _).symm) :=
is_limit.mk' _ $
begin
  intro s,
  refine ⟨prod.lift (pullback_cone.snd s ≫ limits.prod.fst) (pullback_cone.fst s), limit.lift_π _ _, _, _⟩,
  { apply prod.hom_ext,
    erw [assoc, limits.prod.map_fst, prod.lift_fst_assoc, comp_id],
    slice_lhs 2 3 {erw limits.prod.map_snd},
    rw [prod.lift_snd_assoc, pullback_cone.condition s] },
  { intros m m₁ m₂,
    apply prod.hom_ext,
    erw [prod.lift_fst, ← m₂, assoc, limits.prod.map_fst, comp_id],
    simpa using m₁ }
end

def pullback_flip {W X Y Z : C} {f : W ⟶ X} {g : W ⟶ Y} {h : X ⟶ Z} {k : Y ⟶ Z} {comm : f ≫ h = g ≫ k} (t : is_limit (pullback_cone.mk _ _ comm.symm)) :
  is_limit (pullback_cone.mk _ _ comm) :=
is_limit.mk' _ $ λ s,
begin
  refine ⟨(pullback_cone.is_limit.lift' t _ _ s.condition.symm).1,
          (pullback_cone.is_limit.lift' t _ _ _).2.2,
          (pullback_cone.is_limit.lift' t _ _ _).2.1, λ m m₁ m₂, t.hom_ext _⟩,
  apply (pullback_cone.mk g f _).equalizer_ext,
  { rw (pullback_cone.is_limit.lift' t _ _ _).2.1,
    exact m₂ },
  { rw (pullback_cone.is_limit.lift' t _ _ _).2.2,
    exact m₁ },
end

def pullback_square_iso {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z) [mono h] [is_iso g] (comm : f ≫ h = g ≫ k) :
  is_limit (pullback_cone.mk _ _ comm) :=
is_limit.mk''' _ (by dsimp [pullback_cone.mk]; apply_instance) $
  λ s, ⟨s.snd ≫ inv g, by erw [assoc, is_iso.inv_hom_id g, comp_id] ⟩

def left_iso_has_pullback_top {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z) [mono h] [is_iso g] (comm : f ≫ h = g ≫ k) :
  has_pullback_top g k h :=
{ top := f,
  comm := comm,
  is_pb := pullback_square_iso f g h k comm }

def pullback_square_iso' {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z) [is_iso f] [mono k] (comm : f ≫ h = g ≫ k) :
  is_limit (pullback_cone.mk _ _ comm) :=
is_limit.mk' _ $
begin
  intro s,
  refine ⟨pullback_cone.fst s ≫ inv f, _, _, _⟩,
  erw [assoc, is_iso.inv_hom_id, comp_id],
  erw [← cancel_mono k, assoc, ← comm, assoc, is_iso.inv_hom_id_assoc, pullback_cone.condition s],
  intros m m₁ m₂,
  erw [(as_iso f).eq_comp_inv, m₁]
end

def top_iso_has_pullback_top {W X Y Z : C} (f : W ⟶ X) (g : W ⟶ Y) (h : X ⟶ Z) (k : Y ⟶ Z) [is_iso f] [mono k] (comm : f ≫ h = g ≫ k) :
  has_pullback_top g k h :=
{ top := f,
  comm := comm,
  is_pb := pullback_square_iso' f g h k comm }

lemma mono_of_pullback (X Y : C) (f : X ⟶ Y)
  (hl : is_limit (pullback_cone.mk (𝟙 X) (𝟙 X) (by simp) : pullback_cone f f)) : mono f :=
begin
  split, intros,
  set new_cone : pullback_cone f f := pullback_cone.mk g h w,
  exact (hl.fac new_cone walking_cospan.left).symm.trans (hl.fac new_cone walking_cospan.right),
end

def pullback_of_mono {X Y : C} (f : X ⟶ Y) [hf : mono f] :
  is_limit (pullback_cone.mk (𝟙 X) (𝟙 X) rfl : pullback_cone f f) :=
pullback_square_iso' _ _ _ _ _

def mono_self_has_pullback_top {X Y : C} (f : X ⟶ Y) [hf : mono f] :
  has_pullback_top (𝟙 _) f f :=
{ top := 𝟙 _,
  comm := by simp,
  is_pb := pullback_of_mono f }

universe u₂
variables {D : Type u₂} [category.{v} D] (F : C ⥤ D)

def cone_cospan_equiv :
  cone (cospan (F.map f) (F.map g)) ≌ cone (cospan f g ⋙ F) :=
cones.postcompose_equivalence (iso.symm (diagram_iso_cospan _))

local attribute [tidy] tactic.case_bash

def convert_pb
  {W X Y Z : C}
  {f : W ⟶ X} {g : X ⟶ Z} {h : W ⟶ Y} {k : Y ⟶ Z} (comm : f ≫ g = h ≫ k) :
(cones.postcompose (diagram_iso_cospan _).hom).obj (F.map_cone (pullback_cone.mk _ _ comm)) ≅
    (pullback_cone.mk (F.map f) (F.map h) (by rw [← F.map_comp, comm, F.map_comp]) : pullback_cone (F.map g) (F.map k)) :=
cones.ext (iso.refl _) (by { dsimp [diagram_iso_cospan], tidy })

def thing2
  {W X Y Z : C}
  {f : W ⟶ X} {g : X ⟶ Z} {h : W ⟶ Y} {k : Y ⟶ Z} (comm : f ≫ g = h ≫ k) :
is_limit (F.map_cone (pullback_cone.mk _ _ comm)) ≅ is_limit (pullback_cone.mk (F.map f) (F.map h) (by rw [← F.map_comp, comm, F.map_comp]) : pullback_cone (F.map g) (F.map k)) :=
{ hom := λ p,
  begin
    apply is_limit.of_iso_limit _ (convert_pb F comm),
    apply is_limit.of_right_adjoint (cones.postcompose_equivalence ((diagram_iso_cospan _).symm)).inverse p,
  end,
  inv := λ p,
  begin
    have := is_limit.of_right_adjoint (cones.postcompose_equivalence (diagram_iso_cospan (cospan g k ⋙ F))).inverse p,
    apply is_limit.of_iso_limit this _,
    refine cones.ext (iso.refl _) _,
    dsimp [diagram_iso_cospan],
    simp_rw [id_comp],
    rintro (_ | _ | _),
    { dsimp, rw [comp_id, F.map_comp] },
    { dsimp, rw [comp_id] },
    { dsimp, rw [comp_id] },
  end,
  hom_inv_id' := subsingleton.elim _ _,
  inv_hom_id' := subsingleton.elim _ _ }

def preserves_pullback_cone
  [preserves_limits_of_shape walking_cospan F] {W X Y Z : C}
  (f : W ⟶ X) (g : X ⟶ Z) (h : W ⟶ Y) (k : Y ⟶ Z) (comm : f ≫ g = h ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
is_limit (pullback_cone.mk (F.map f) (F.map h) (by rw [← F.map_comp, comm, F.map_comp]) : pullback_cone (F.map g) (F.map k)) :=
(thing2 F comm).hom (preserves_limit.preserves t)

def reflects_pullback_cone
  [reflects_limits_of_shape walking_cospan F] {W X Y Z : C}
  {f : W ⟶ X} {g : X ⟶ Z} {h : W ⟶ Y} {k : Y ⟶ Z} (comm : f ≫ g = h ≫ k)
  (t : is_limit (pullback_cone.mk (F.map f) (F.map h) (by rw [← F.map_comp, comm, F.map_comp]) : pullback_cone (F.map g) (F.map k))) :
is_limit (pullback_cone.mk _ _ comm) :=
reflects_limit.reflects ((thing2 F comm).inv t)

lemma preserves_mono_of_preserves_pullback
  [preserves_limits_of_shape walking_cospan F] (X Y : C) (f : X ⟶ Y) [mono f] :
  mono (F.map f) :=
begin
  apply mono_of_pullback,
  have : 𝟙 (F.obj X) = F.map (𝟙 X),
    rw F.map_id,
  convert preserves_pullback_cone F (𝟙 _) f (𝟙 _) f rfl (pullback_of_mono f),
end

def preserves_walking_cospan_of_preserves_pb_cone {h : W ⟶ _} {k} (comm : h ≫ f = k ≫ g) (is_lim : is_limit (pullback_cone.mk _ _ comm))
  (t : is_limit (pullback_cone.mk (F.map h) (F.map k) (by rw [← F.map_comp, comm, F.map_comp]) : pullback_cone (F.map f) (F.map g))) :
  preserves_limit (cospan f g) F :=
begin
  apply preserves_limit_of_preserves_limit_cone is_lim,
  apply ((thing2 _ _).inv t),
end

def preserves_hpb [preserves_limits_of_shape walking_cospan F] {g : X ⟶ Z} {h : W ⟶ Y} {k : Y ⟶ Z} (t : has_pullback_top h k g) :
has_pullback_top (F.map h) (F.map k) (F.map g) :=
{ top := F.map t.top,
  comm := by rw [← F.map_comp, t.comm, F.map_comp],
  is_pb := preserves_pullback_cone F _ _ _ _ t.comm t.is_pb }

def fully_faithful_reflects_hpb [reflects_limits_of_shape walking_cospan F] [full F] [faithful F] {g : X ⟶ Z} {h : W ⟶ Y} {k : Y ⟶ Z}
  (t : has_pullback_top (F.map h) (F.map k) (F.map g)) :
has_pullback_top h k g :=
{ top := F.preimage t.top,
  comm := by { apply F.map_injective, simp [t.comm] },
  is_pb :=
  begin
    refine reflects_pullback_cone F _ _,
    convert t.is_pb,
    simp,
  end }

-- Strictly we don't need the assumption that C has pullbacks but oh well
def over_forget_preserves_hpb [has_pullbacks.{v} C] {B : C} {X Y Z W : over B} (g : X ⟶ Z) (h : Z ⟶ W) (k : Y ⟶ W) (t : has_pullback_top g h k) :
  has_pullback_top g.left h.left k.left :=
preserves_hpb (over.forget _) t

def over_forget_reflects_hpb {B : C} {X Y Z W : over B} {g : X ⟶ Z} {h : Z ⟶ W} {k : Y ⟶ W}
  (t : has_pullback_top g.left h.left k.left ) :
  has_pullback_top g h k :=
{ top :=
  begin
    apply over.hom_mk t.top _,
    simp only [auto_param_eq, ← over.w k, t.comm_assoc, over.w h, over.w g],
  end,
  comm := by { ext1, exact t.comm },
  is_pb :=
  begin
    apply reflects_pullback_cone (over.forget _),
    apply t.is_pb,
    refine ⟨λ K, by apply_instance⟩,
  end }


import Std

def Nat.digitCharInv! : Char → Nat
| '0' => 0
| '1' => 1
| '2' => 2
| '3' => 3
| '4' => 4
| '5' => 5
| '6' => 6
| '7' => 7
| '8' => 8
| '9' => 9
| 'a' | 'A' => 0xa
| 'b' | 'B' => 0xb
| 'c' | 'C' => 0xc
| 'd' | 'D' => 0xd
| 'e' | 'E' => 0xe
| 'f' | 'F' => 0xf
| _   => panic! "nan"

def Char.isHexDigit : Char → Bool
| '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9'
| 'a' | 'b' | 'c' | 'd' | 'e' | 'f'
| 'A' | 'B' | 'C' | 'D' | 'E' | 'F' => true
| _ => false

def Nat.ofDigits? (base : Nat) (s : String) : Option Nat :=
  s.foldl (fun acc c =>
    acc.bind fun acc =>
      if c.isHexDigit then
        let d := Nat.digitCharInv! c
        if d < base then
          some <| acc * base + d
        else
          none
      else
        none)
    (some 0)

@[simp] theorem UInt32.toNat_ofUInt8 : UInt32.toNat (UInt8.toUInt32 x) = x.val := by
  cases x; case mk val =>
  cases val; case mk val isLt =>
  have : val < 4294967295 + 1 := Nat.le_trans isLt (by decide)
  simp [UInt8.size] at isLt
  simp only [toNat]
  apply Nat.mod_eq_of_lt this

instance : Coe UInt8 Char where
  coe b := ⟨UInt8.toUInt32 b, by
    rcases b with ⟨⟨x,h⟩⟩
    apply Or.inl
    simp
    apply Nat.lt_trans h (by decide)
  ⟩

def Char.toUInt8 (c : Char) (h : c.val.val < UInt8.size := by decide) : UInt8 :=
  ⟨c.val.val, h⟩

instance (h : c.val.val < UInt8.size := by decide) : CoeDep Char c UInt8 := ⟨c.toUInt8 h⟩

structure ThunkCache (a : Unit → α) where
  val : Thunk α
  h_val : val.get = a ()

def ThunkCache.new : ThunkCache a := ⟨Thunk.mk a, by simp [Thunk.get]⟩
instance : Inhabited (ThunkCache a) := ⟨.new⟩

def List.pmap (L : List α) (f : (a : α) → a ∈ L → β) : List β :=
  match L with
  | [] => []
  | x::xs => (f x (List.Mem.head _)) :: xs.pmap (fun a h => f a (List.Mem.tail _ h))

@[simp] theorem String.length_pushn (s : String) (c n)
  : (s.pushn c n).length = s.length + n := by
  induction n
  . simp [pushn, Nat.repeat]
  . simp [pushn, Nat.repeat, push, length]
    rw [Nat.add_succ, Nat.add_succ]
    congr

@[simp] theorem String.length_append (s1 s2 : String)
  : (s1 ++ s2).length = s1.length + s2.length := by
  simp [HAppend.hAppend, Append.append, append, length]

@[simp] theorem String.take_mk (L : List Char) (n)
  : (String.mk L).take n = String.mk (L.take n)
  := sorry

@[simp] theorem String.drop_mk (L : List Char) (n)
  : (String.mk L).drop n = String.mk (L.drop n)
  := sorry

@[simp] theorem String.length_take (s : String) (n)
  : (s.take n).length = min s.length n
  := by cases s; simp [length, Nat.min_comm]

@[simp] theorem String.length_drop (s : String) (n)
  : (s.drop n).length = s.length - n
  := by cases s; simp [length, Nat.min_comm]

theorem List.mem_zipWith (h : x ∈ List.zipWith f L1 L2)
  : ∃ y z, x = f y z ∧ y ∈ L1 ∧ z ∈ L2
  := by induction L1 generalizing x L2
        . simp at h
        . next ih =>
          cases L2 <;> simp at *
          cases h
          . subst_vars
            exact ⟨_, _, rfl, .inl rfl, .inl rfl⟩
          . have := ih (by assumption)
            rcases this with ⟨y,z,rfl,hy,hz⟩
            refine ⟨y,z, rfl, .inr hy, .inr hz⟩

theorem List.mem_take (h : x ∈ List.take n L)
  : x ∈ L
  := by induction n generalizing L <;> cases L <;> simp at *
        next ih _ _ =>
        cases h
        . apply Or.inl; assumption
        . apply Or.inr; apply ih; assumption

@[simp]
theorem List.length_join_replicate : (replicate n L).join.length = n * L.length := by
  induction n
  . simp
  . simp [Nat.succ_mul, Nat.add_comm]
    congr

def Function.update (f : α → β) [DecidableEq α] (x v) :=
  fun i => if i = x then v else f i


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.AffineScheme
import ring_theory.nilpotent
import topology.sheaves.sheaf_condition.sites
import category_theory.limits.constructions.binary_products
import algebra.category.Ring.constructions
import ring_theory.integral_domain
import ring_theory.local_properties

/-!
# Basic properties of schemes

We provide some basic properties of schemes

## Main definition
* `algebraic_geometry.is_integral`: A scheme is integral if it is nontrivial and all nontrivial
  components of the structure sheaf are integral domains.
* `algebraic_geometry.is_reduced`: A scheme is reduced if all the components of the structure sheaf
  is reduced.
-/

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

instance : t0_space X.carrier :=
begin
  rw t0_space_iff_not_inseparable,
  intros x y h h',
  obtain ⟨U, R, ⟨e⟩⟩ := X.local_affine x,
  have hy := (h' _ U.1.2).mp U.2,
  erw ← subtype_inseparable_iff (⟨x, U.2⟩ : U.1.1) (⟨y, hy⟩ : U.1.1) at h',
  let e' : U.1 ≃ₜ prime_spectrum R :=
    homeo_of_iso ((LocallyRingedSpace.forget_to_SheafedSpace ⋙ SheafedSpace.forget _).map_iso e),
  have := t0_space_of_injective_of_continuous e'.injective e'.continuous,
  rw t0_space_iff_not_inseparable at this,
  exact this ⟨x, U.2⟩ ⟨y, hy⟩ (by simpa using h) h'
end

instance : quasi_sober X.carrier :=
begin
  apply_with (quasi_sober_of_open_cover
    (set.range (λ x, set.range $ (X.affine_cover.map x).1.base)))
    { instances := ff },
  { rintro ⟨_,i,rfl⟩, exact (X.affine_cover.is_open i).base_open.open_range },
  { rintro ⟨_,i,rfl⟩,
    exact @@open_embedding.quasi_sober _ _ _
      (homeomorph.of_embedding _ (X.affine_cover.is_open i).base_open.to_embedding)
      .symm.open_embedding prime_spectrum.quasi_sober },
  { rw [set.top_eq_univ, set.sUnion_range, set.eq_univ_iff_forall],
    intro x, exact ⟨_, ⟨_, rfl⟩, X.affine_cover.covers x⟩ }
end

/-- A scheme `X` is reduced if all `𝒪ₓ(U)` are reduced. -/
class is_reduced : Prop :=
(component_reduced : ∀ U, _root_.is_reduced (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_reduced.component_reduced

lemma is_reduced_of_stalk_is_reduced [∀ x : X.carrier, _root_.is_reduced (X.presheaf.stalk x)] :
  is_reduced X :=
begin
  refine ⟨λ U, ⟨λ s hs, _⟩⟩,
  apply presheaf.section_ext X.sheaf U s 0,
  intro x,
  rw ring_hom.map_zero,
  change X.presheaf.germ x s = 0,
  exact (hs.map _).eq_zero
end

instance stalk_is_reduced_of_reduced [is_reduced X] (x : X.carrier) :
  _root_.is_reduced (X.presheaf.stalk x) :=
begin
  constructor,
  rintros g ⟨n, e⟩,
  obtain ⟨U, hxU, s, rfl⟩ := X.presheaf.germ_exist x g,
  rw [← map_pow, ← map_zero (X.presheaf.germ ⟨x, hxU⟩)] at e,
  obtain ⟨V, hxV, iU, iV, e'⟩ := X.presheaf.germ_eq x hxU hxU _ 0 e,
  rw [map_pow, map_zero] at e',
  replace e' := (is_nilpotent.mk _ _ e').eq_zero,
  erw ← concrete_category.congr_hom (X.presheaf.germ_res iU ⟨x, hxV⟩) s,
  rw [comp_apply, e', map_zero]
end

lemma is_reduced_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_reduced Y] : is_reduced X :=
begin
  constructor,
  intro U,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  exact is_reduced_of_injective (inv $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U))
    (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) : Y.presheaf.obj _ ≅ _).symm
      .CommRing_iso_to_ring_equiv.injective
end

instance {R : CommRing} [H : _root_.is_reduced R] : is_reduced (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_reduced_of_stalk_is_reduced { instances := ff },
  intro x, dsimp,
  haveI : _root_.is_reduced (CommRing.of $ localization.at_prime (prime_spectrum.as_ideal x)),
  { dsimp, apply_instance },
  exact is_reduced_of_injective (structure_sheaf.stalk_iso R x).hom
    (structure_sheaf.stalk_iso R x).CommRing_iso_to_ring_equiv.injective,
end

lemma affine_is_reduced_iff (R : CommRing) :
  is_reduced (Scheme.Spec.obj $ op R) ↔ _root_.is_reduced R :=
begin
  refine ⟨_, λ h, by exactI infer_instance⟩,
  intro h,
  resetI,
  haveI : _root_.is_reduced (LocallyRingedSpace.Γ.obj (op $ Spec.to_LocallyRingedSpace.obj $ op R)),
  { change _root_.is_reduced ((Scheme.Spec.obj $ op R).presheaf.obj $ op ⊤), apply_instance },
  exact is_reduced_of_injective (to_Spec_Γ R)
    ((as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv.injective)
end

lemma is_reduced_of_is_affine_is_reduced [is_affine X]
  [h : _root_.is_reduced (X.presheaf.obj (op ⊤))] : is_reduced X :=
begin
  haveI : is_reduced (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_reduced_iff, exact h },
  exact is_reduced_of_open_immersion X.iso_Spec.hom,
end

/-- To show that a statement `P` holds for all open subsets of all schemes, it suffices to show that
1. In any scheme `X`, if `P` holds for an open cover of `U`, then `P` holds for `U`.
2. For an open immerison `f : X ⟶ Y`, if `P` holds for the entire space of `X`, then `P` holds for
  the image of `f`.
3. `P` holds for the entire space of an affine scheme.
-/
lemma reduce_to_affine_global (P : ∀ (X : Scheme) (U : opens X.carrier), Prop)
  (h₁ : ∀ (X : Scheme) (U : opens X.carrier),
    (∀ (x : U), ∃ {V} (h : x.1 ∈ V) (i : V ⟶ U), P X V) → P X U)
  (h₂ : ∀ {X Y} (f : X ⟶ Y) [hf : is_open_immersion f], ∃ {U : set X.carrier} {V : set Y.carrier}
    (hU : U = ⊤) (hV : V = set.range f.1.base), P X ⟨U, hU.symm ▸ is_open_univ⟩ →
      P Y ⟨V, hV.symm ▸ hf.base_open.open_range⟩)
  (h₃ : ∀ (R : CommRing), P (Scheme.Spec.obj $ op R) ⊤) :
  ∀ (X : Scheme) (U : opens X.carrier), P X U :=
begin
  intros X U,
  apply h₁,
  intro x,
  obtain ⟨_,⟨j,rfl⟩,hx,i⟩ := X.affine_basis_cover_is_basis.exists_subset_of_mem_open x.prop U.2,
  let U' : opens _ := ⟨_, (X.affine_basis_cover.is_open j).base_open.open_range⟩,
  let i' : U' ⟶ U :=
    hom_of_le i,
  refine ⟨U', hx, i', _⟩,
  obtain ⟨_,_,rfl,rfl,h₂'⟩ := h₂ (X.affine_basis_cover.map j),
  apply h₂',
  apply h₃
end
.

lemma eq_zero_of_basic_open_empty {X : Scheme} [hX : is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj (op U)) (hs : X.basic_open s = ∅) :
  s = 0 :=
begin
  apply Top.presheaf.section_ext X.sheaf U,
  simp_rw ring_hom.map_zero,
  unfreezingI { revert X U hX s },
  refine reduce_to_affine_global _ _ _ _,
  { intros X U hx hX s hs x,
    obtain ⟨V, hx, i, H⟩ := hx x,
    unfreezingI { specialize H (X.presheaf.map i.op s) },
    erw Scheme.basic_open_res at H,
    rw [hs, ← subtype.coe_injective.eq_iff, opens.empty_eq, opens.inter_eq, inf_bot_eq] at H,
    specialize H rfl ⟨x, hx⟩,
    erw Top.presheaf.germ_res_apply at H,
    exact H },
  { rintros X Y f hf,
    have e : (f.val.base) ⁻¹' set.range ⇑(f.val.base) = ⊤,
    { rw [← set.image_univ, set.preimage_image_eq _ hf.base_open.inj, set.top_eq_univ] },
    refine ⟨_, _, e, rfl, _⟩,
    rintros H hX s hs ⟨_, x, rfl⟩,
    unfreezingI { haveI := is_reduced_of_open_immersion f },
    specialize H (f.1.c.app _ s) _ ⟨x, by { change x ∈ (f.val.base) ⁻¹' _, rw e, trivial }⟩,
    { rw [← Scheme.preimage_basic_open, hs], ext1, simp [opens.map] },
    { erw ← PresheafedSpace.stalk_map_germ_apply f.1 ⟨_,_⟩ ⟨x,_⟩ at H,
      apply_fun (inv $ PresheafedSpace.stalk_map f.val x) at H,
      erw [category_theory.is_iso.hom_inv_id_apply, map_zero] at H,
      exact H } },
  { intros R hX s hs x,
    erw [basic_open_eq_of_affine', prime_spectrum.basic_open_eq_bot_iff] at hs,
    replace hs := (hs.map (Spec_Γ_identity.app R).inv),
    -- what the hell?!
    replace hs := @is_nilpotent.eq_zero _ _ _ _ (show _, from _) hs,
    rw iso.hom_inv_id_apply at hs,
    rw [hs, map_zero],
    exact @@is_reduced.component_reduced hX ⊤ }
end

@[simp]
lemma basic_open_eq_bot_iff {X : Scheme} [is_reduced X] {U : opens X.carrier}
  (s : X.presheaf.obj $ op U) :
  X.basic_open s = ⊥ ↔ s = 0 :=
begin
  refine ⟨eq_zero_of_basic_open_empty s, _⟩,
  rintro rfl,
  simp,
end

/-- A scheme `X` is integral if its carrier is nonempty,
and `𝒪ₓ(U)` is an integral domain for each `U ≠ ∅`. -/
class is_integral : Prop :=
(nonempty : nonempty X.carrier . tactic.apply_instance)
(component_integral : ∀ (U : opens X.carrier) [_root_.nonempty U],
  is_domain (X.presheaf.obj (op U)) . tactic.apply_instance)

attribute [instance] is_integral.component_integral is_integral.nonempty

instance [h : is_integral X] : is_domain (X.presheaf.obj (op ⊤)) :=
@@is_integral.component_integral _ _ (by simp)

@[priority 900]
instance is_reduced_of_is_integral [is_integral X] : is_reduced X :=
begin
  constructor,
  intro U,
  cases U.1.eq_empty_or_nonempty,
  { have : U = ∅ := subtype.eq h,
    haveI := CommRing.subsingleton_of_is_terminal (X.sheaf.is_terminal_of_eq_empty this),
    change _root_.is_reduced (X.sheaf.val.obj (op U)),
    apply_instance },
  { haveI : nonempty U := by simpa, apply_instance }
end

instance is_irreducible_of_is_integral [is_integral X] : irreducible_space X.carrier :=
begin
  by_contradiction H,
  replace H : ¬ is_preirreducible (⊤ : set X.carrier) := λ h,
    H { to_preirreducible_space := ⟨h⟩, to_nonempty := infer_instance },
  simp_rw [is_preirreducible_iff_closed_union_closed, not_forall, not_or_distrib] at H,
  rcases H with ⟨S, T, hS, hT, h₁, h₂, h₃⟩,
  erw not_forall at h₂ h₃,
  simp_rw not_forall at h₂ h₃,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ : opens X.carrier) := ⟨⟨_, h₂.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Tᶜ, hT.1⟩ : opens X.carrier) := ⟨⟨_, h₃.some_spec.some_spec⟩⟩,
  haveI : nonempty (⟨Sᶜ, hS.1⟩ ⊔ ⟨Tᶜ, hT.1⟩ : opens X.carrier) :=
    ⟨⟨_, or.inl h₂.some_spec.some_spec⟩⟩,
  let e : X.presheaf.obj _ ≅ CommRing.of _ := (X.sheaf.is_product_of_disjoint ⟨_, hS.1⟩ ⟨_, hT.1⟩ _)
    .cone_point_unique_up_to_iso (CommRing.prod_fan_is_limit _ _),
  apply_with false_of_nontrivial_of_product_domain { instances := ff },
  { exact e.symm.CommRing_iso_to_ring_equiv.is_domain _ },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { apply X.to_LocallyRingedSpace.component_nontrivial },
  { ext x,
    split,
    { rintros ⟨hS,hT⟩,
      cases h₁ (show x ∈ ⊤, by trivial),
      exacts [hS h, hT h] },
    { intro x, exact x.rec _ } }
end

lemma is_integral_of_is_irreducible_is_reduced [is_reduced X] [H : irreducible_space X.carrier] :
  is_integral X :=
begin
  split, refine λ U hU, ⟨λ a b e, _,
    (@@LocallyRingedSpace.component_nontrivial X.to_LocallyRingedSpace U hU).1⟩,
  simp_rw [← basic_open_eq_bot_iff, ← opens.not_nonempty_iff_eq_bot],
  by_contra' h,
  obtain ⟨_, ⟨x, hx₁, rfl⟩, ⟨x, hx₂, e'⟩⟩ := @@nonempty_preirreducible_inter _ H.1
    (X.basic_open a).2 (X.basic_open b).2
    h.1 h.2,
  replace e' := subtype.eq e',
  subst e',
  replace e := congr_arg (X.presheaf.germ x) e,
  rw [ring_hom.map_mul, ring_hom.map_zero] at e,
  refine @zero_ne_one (X.presheaf.stalk x.1) _ _ (is_unit_zero_iff.1 _),
  convert hx₁.mul hx₂,
  exact e.symm
end

lemma is_integral_iff_is_irreducible_and_is_reduced :
  is_integral X ↔ irreducible_space X.carrier ∧ is_reduced X :=
⟨λ _, by exactI ⟨infer_instance, infer_instance⟩,
  λ ⟨_, _⟩, by exactI is_integral_of_is_irreducible_is_reduced X⟩

lemma is_integral_of_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [is_integral Y] [nonempty X.carrier] : is_integral X :=
begin
  constructor,
  intros U hU,
  have : U = (opens.map f.1.base).obj (H.base_open.is_open_map.functor.obj U),
  { ext1, exact (set.preimage_image_eq _ H.base_open.inj).symm },
  rw this,
  haveI : is_domain (Y.presheaf.obj (op (H.base_open.is_open_map.functor.obj U))),
  { apply_with is_integral.component_integral { instances := ff },
    apply_instance,
    refine ⟨⟨_, _, hU.some.prop, rfl⟩⟩ },
  exact (as_iso $ f.1.c.app (op $ H.base_open.is_open_map.functor.obj U) :
    Y.presheaf.obj _ ≅ _).symm.CommRing_iso_to_ring_equiv.is_domain _
end

instance {R : CommRing} [H : is_domain R] : is_integral (Scheme.Spec.obj $ op R) :=
begin
  apply_with is_integral_of_is_irreducible_is_reduced { instances := ff },
  { apply_instance },
  { dsimp [Spec.Top_obj],
    apply_instance },
end

lemma affine_is_integral_iff (R : CommRing) :
  is_integral (Scheme.Spec.obj $ op R) ↔ is_domain R :=
⟨λ h, by exactI ring_equiv.is_domain ((Scheme.Spec.obj $ op R).presheaf.obj _)
  (as_iso $ to_Spec_Γ R).CommRing_iso_to_ring_equiv, λ h, by exactI infer_instance⟩

lemma is_integral_of_is_affine_is_domain [is_affine X] [nonempty X.carrier]
  [h : is_domain (X.presheaf.obj (op ⊤))] : is_integral X :=
begin
  haveI : is_integral (Scheme.Spec.obj (op (Scheme.Γ.obj (op X)))),
  { rw affine_is_integral_iff, exact h },
  exact is_integral_of_open_immersion X.iso_Spec.hom,
end

lemma map_injective_of_is_integral [is_integral X] {U V : opens X.carrier} (i : U ⟶ V)
  [H : nonempty U] :
  function.injective (X.presheaf.map i.op) :=
begin
  rw injective_iff_map_eq_zero,
  intros x hx,
  rw ← basic_open_eq_bot_iff at ⊢ hx,
  rw Scheme.basic_open_res at hx,
  revert hx,
  contrapose!,
  simp_rw [← opens.not_nonempty_iff_eq_bot, not_not],
  apply nonempty_preirreducible_inter U.prop (RingedSpace.basic_open _ _).prop,
  simpa using H
end

end algebraic_geometry


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

/-!
# The category of bipointed types

This defines `Bipointed`, the category of bipointed types.

## TODO

Monoidal structure
-/

open category_theory

universes u
variables {α β : Type*}

/-- The category of bipointed types. -/
structure Bipointed : Type.{u + 1} :=
(X : Type.{u})
(to_prod : X × X)

namespace Bipointed

instance : has_coe_to_sort Bipointed Type* := ⟨X⟩

attribute [protected] Bipointed.X

/-- Turns a bipointing into a bipointed type. -/
def of {X : Type*} (to_prod : X × X) : Bipointed := ⟨X, to_prod⟩

alias of ← prod.Bipointed

instance : inhabited Bipointed := ⟨of ((), ())⟩

/-- Morphisms in `Bipointed`. -/
@[ext] protected structure hom (X Y : Bipointed.{u}) : Type u :=
(to_fun : X → Y)
(map_fst : to_fun X.to_prod.1 = Y.to_prod.1)
(map_snd : to_fun X.to_prod.2 = Y.to_prod.2)

namespace hom

/-- The identity morphism of `X : Bipointed`. -/
@[simps] def id (X : Bipointed) : hom X X := ⟨id, rfl, rfl⟩

instance (X : Bipointed) : inhabited (hom X X) := ⟨id X⟩

/-- Composition of morphisms of `Bipointed`. -/
@[simps] def comp {X Y Z : Bipointed.{u}} (f : hom X Y) (g : hom Y Z) : hom X Z :=
⟨g.to_fun ∘ f.to_fun, by rw [function.comp_apply, f.map_fst, g.map_fst],
  by rw [function.comp_apply, f.map_snd, g.map_snd]⟩

end hom

instance large_category : large_category Bipointed :=
{ hom := hom,
  id := hom.id,
  comp := @hom.comp,
  id_comp' := λ _ _ _, hom.ext _ _ rfl,
  comp_id' := λ _ _ _, hom.ext _ _ rfl,
  assoc' := λ _ _ _ _ _ _ _, hom.ext _ _ rfl }

instance concrete_category : concrete_category Bipointed :=
{ forget := { obj := Bipointed.X, map := @hom.to_fun },
  forget_faithful := ⟨@hom.ext⟩ }

/-- Swaps the pointed elements of a bipointed type. `prod.swap` as a functor. -/
@[simps] def swap : Bipointed ⥤ Bipointed :=
{ obj := λ X, ⟨X, X.to_prod.swap⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd, f.map_fst⟩ }

/-- The equivalence between `Bipointed` and itself induced by `prod.swap` both ways. -/
@[simps] def swap_equiv : Bipointed ≌ Bipointed :=
equivalence.mk swap swap
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, { hom := ⟨id, rfl, rfl⟩, inv := ⟨id, rfl, rfl⟩ }) $ λ X Y f, rfl)

@[simp] lemma swap_equiv_symm : swap_equiv.symm = swap_equiv := rfl

end Bipointed

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the second point. -/
def Bipointed_to_Pointed_fst : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.1⟩, map := λ X Y f, ⟨f.to_fun, f.map_fst⟩ }

/-- The forgetful functor from `Bipointed` to `Pointed` which forgets about the first point. -/
def Bipointed_to_Pointed_snd : Bipointed ⥤ Pointed :=
{ obj := λ X, ⟨X, X.to_prod.2⟩, map := λ X Y f, ⟨f.to_fun, f.map_snd⟩ }

@[simp] lemma Bipointed_to_Pointed_fst_comp_forget :
  Bipointed_to_Pointed_fst ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma Bipointed_to_Pointed_snd_comp_forget :
  Bipointed_to_Pointed_snd ⋙ forget Pointed = forget Bipointed := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_fst :
  Bipointed.swap ⋙ Bipointed_to_Pointed_fst = Bipointed_to_Pointed_snd := rfl

@[simp] lemma swap_comp_Bipointed_to_Pointed_snd :
  Bipointed.swap ⋙ Bipointed_to_Pointed_snd = Bipointed_to_Pointed_fst := rfl

--TODO: This is actually an equivalence
/-- The functor from `Pointed` to `Bipointed` which adds a second point. -/
def Pointed_to_Bipointed_fst : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, X.point, none⟩,
  map := λ X Y f, ⟨option.map f.to_fun, congr_arg _ f.map_point, rfl⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

--TODO: This is actually an equivalence
/-- The functor from `Pointed` to `Bipointed` which adds a first point. -/
def Pointed_to_Bipointed_snd : Pointed.{u} ⥤ Bipointed :=
{ obj := λ X, ⟨option X, none, X.point⟩,
  map := λ X Y f, ⟨option.map f.to_fun, rfl, congr_arg _ f.map_point⟩,
  map_id' := λ X, Bipointed.hom.ext _ _ option.map_id,
  map_comp' := λ X Y Z f g, Bipointed.hom.ext _ _ (option.map_comp_map  _ _).symm }

@[simp] lemma Pointed_to_Bipointed_fst_comp :
  Pointed_to_Bipointed_fst ⋙ Bipointed.swap = Pointed_to_Bipointed_snd := rfl

@[simp] lemma Pointed_to_Bipointed_snd_comp :
  Pointed_to_Bipointed_snd ⋙ Bipointed.swap = Pointed_to_Bipointed_fst := rfl

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_fst` and `Bipointed_to_Pointed_fst`.
-/
def Pointed_to_Bipointed_fst_Bipointed_to_Pointed_fst_adjunction :
  Pointed_to_Bipointed_fst ⊣ Bipointed_to_Pointed_fst :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_fst⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.2 f.to_fun, f.map_point, rfl⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_snd.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }

/-- The free/forgetful adjunction between `Pointed_to_Bipointed_snd` and `Bipointed_to_Pointed_snd`.
-/
def Pointed_to_Bipointed_snd_Bipointed_to_Pointed_snd_adjunction :
  Pointed_to_Bipointed_snd ⊣ Bipointed_to_Pointed_snd :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ X Y, { to_fun := λ f, ⟨f.to_fun ∘ option.some, f.map_snd⟩,
                        inv_fun := λ f, ⟨λ o, o.elim Y.to_prod.1 f.to_fun, rfl, f.map_point⟩,
                        left_inv := λ f, by { ext, cases x, exact f.map_fst.symm, refl },
                        right_inv := λ f, Pointed.hom.ext _ _ rfl },
  hom_equiv_naturality_left_symm' := λ X' X Y f g, by { ext, cases x; refl } }


/-
Copyright (c) 2021 Anne Baanen. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Anne Baanen
-/

import logic.function.basic
import tactic.lint
import tactic.norm_cast

/-!
# Typeclass for a type `F` with an injective map to `A → B`

This typeclass is primarily for use by homomorphisms like `monoid_hom` and `linear_map`.

## Basic usage of `fun_like`

A typical type of morphisms should be declared as:
```
structure my_hom (A B : Type*) [my_class A] [my_class B] :=
(to_fun : A → B)
(map_op' : ∀ {x y : A}, to_fun (my_class.op x y) = my_class.op (to_fun x) (to_fun y))

namespace my_hom

variables (A B : Type*) [my_class A] [my_class B]

-- This instance is optional if you follow the "morphism class" design below:
instance : fun_like (my_hom A B) A (λ _, B) :=
{ coe := my_hom.to_fun, coe_injective' := λ f g h, by cases f; cases g; congr' }

/-- Helper instance for when there's too many metavariables to apply `to_fun.to_coe_fn` directly. -/
instance : has_coe_to_fun (my_hom A B) (λ _, A → B) := to_fun.to_coe_fn

@[simp] lemma to_fun_eq_coe {f : my_hom A B} : f.to_fun = (f : A → B) := rfl

@[ext] theorem ext {f g : my_hom A B} (h : ∀ x, f x = g x) : f = g := fun_like.ext f g h

/-- Copy of a `my_hom` with a new `to_fun` equal to the old one. Useful to fix definitional
equalities. -/
protected def copy (f : my_hom A B) (f' : A → B) (h : f' = ⇑f) : my_hom A B :=
{ to_fun := f',
  map_op' := h.symm ▸ f.map_op' }

end my_hom
```

This file will then provide a `has_coe_to_fun` instance and various
extensionality and simp lemmas.

## Morphism classes extending `fun_like`

The `fun_like` design provides further benefits if you put in a bit more work.
The first step is to extend `fun_like` to create a class of those types satisfying
the axioms of your new type of morphisms.
Continuing the example above:

```
/-- `my_hom_class F A B` states that `F` is a type of `my_class.op`-preserving morphisms.
You should extend this class when you extend `my_hom`. -/
class my_hom_class (F : Type*) (A B : out_param $ Type*) [my_class A] [my_class B]
  extends fun_like F A (λ _, B) :=
(map_op : ∀ (f : F) (x y : A), f (my_class.op x y) = my_class.op (f x) (f y))

@[simp] lemma map_op {F A B : Type*} [my_class A] [my_class B] [my_hom_class F A B]
  (f : F) (x y : A) : f (my_class.op x y) = my_class.op (f x) (f y) :=
my_hom_class.map_op

-- You can replace `my_hom.fun_like` with the below instance:
instance : my_hom_class (my_hom A B) A B :=
{ coe := my_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := my_hom.map_op' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

The second step is to add instances of your new `my_hom_class` for all types extending `my_hom`.
Typically, you can just declare a new class analogous to `my_hom_class`:

```
structure cooler_hom (A B : Type*) [cool_class A] [cool_class B]
  extends my_hom A B :=
(map_cool' : to_fun cool_class.cool = cool_class.cool)

class cooler_hom_class (F : Type*) (A B : out_param $ Type*) [cool_class A] [cool_class B]
  extends my_hom_class F A B :=
(map_cool : ∀ (f : F), f cool_class.cool = cool_class.cool)

@[simp] lemma map_cool {F A B : Type*} [cool_class A] [cool_class B] [cooler_hom_class F A B]
  (f : F) : f cool_class.cool = cool_class.cool :=
my_hom_class.map_op

-- You can also replace `my_hom.fun_like` with the below instance:
instance : cool_hom_class (cool_hom A B) A B :=
{ coe := cool_hom.to_fun,
  coe_injective' := λ f g h, by cases f; cases g; congr',
  map_op := cool_hom.map_op',
  map_cool := cool_hom.map_cool' }

-- [Insert `has_coe_to_fun`, `to_fun_eq_coe`, `ext` and `copy` here]
```

Then any declaration taking a specific type of morphisms as parameter can instead take the
class you just defined:
```
-- Compare with: lemma do_something (f : my_hom A B) : sorry := sorry
lemma do_something {F : Type*} [my_hom_class F A B] (f : F) : sorry := sorry
```

This means anything set up for `my_hom`s will automatically work for `cool_hom_class`es,
and defining `cool_hom_class` only takes a constant amount of effort,
instead of linearly increasing the work per `my_hom`-related declaration.

-/

-- This instance should have low priority, to ensure we follow the chain
-- `fun_like → has_coe_to_fun`
attribute [instance, priority 10] coe_fn_trans

/-- The class `fun_like F α β` expresses that terms of type `F` have an
injective coercion to functions from `α` to `β`.

This typeclass is used in the definition of the homomorphism typeclasses,
such as `zero_hom_class`, `mul_hom_class`, `monoid_hom_class`, ....
-/
class fun_like (F : Sort*) (α : out_param Sort*) (β : out_param $ α → Sort*) :=
(coe : F → Π a : α, β a)
(coe_injective' : function.injective coe)

section dependent

/-! ### `fun_like F α β` where `β` depends on `a : α` -/

variables (F α : Sort*) (β : α → Sort*)

namespace fun_like

variables {F α β} [i : fun_like F α β]

include i

@[priority 100, -- Give this a priority between `coe_fn_trans` and the default priority
  nolint dangerous_instance] -- `α` and `β` are out_params, so this instance should not be dangerous
instance : has_coe_to_fun F (λ _, Π a : α, β a) := { coe := fun_like.coe }

@[simp]

theorem coe_injective : function.injective (coe_fn : F → Π a : α, β a) :=
fun_like.coe_injective'

@[simp, norm_cast]
theorem coe_fn_eq {f g : F} : (f : Π a : α, β a) = (g : Π a : α, β a) ↔ f = g :=
⟨λ h, @coe_injective _ _ _ i _ _ h, λ h, by cases h; refl⟩

theorem ext' {f g : F} (h : (f : Π a : α, β a) = (g : Π a : α, β a)) : f = g :=
coe_injective h

theorem ext'_iff {f g : F} : f = g ↔ ((f : Π a : α, β a) = (g : Π a : α, β a)) :=
coe_fn_eq.symm

theorem ext (f g : F) (h : ∀ (x : α), f x = g x) : f = g :=
coe_injective (funext h)

theorem ext_iff {f g : F} : f = g ↔ (∀ x, f x = g x) :=
coe_fn_eq.symm.trans function.funext_iff

protected lemma congr_fun {f g : F} (h₁ : f = g) (x : α) : f x = g x :=
congr_fun (congr_arg _ h₁) x

end fun_like

end dependent

section non_dependent

/-! ### `fun_like F α (λ _, β)` where `β` does not depend on `a : α` -/

variables {F α β : Sort*} [i : fun_like F α (λ _, β)]

include i

namespace fun_like

protected lemma congr {f g : F} {x y : α} (h₁ : f = g) (h₂ : x = y) : f x = g y :=
congr (congr_arg _ h₁) h₂

protected lemma congr_arg (f : F) {x y : α} (h₂ : x = y) : f x = f y :=
congr_arg _ h₂

end fun_like

end non_dependent