/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Compiler.IR.Basic
import Lean.Compiler.IR.LiveVars
import Lean.Compiler.IR.Format

namespace Lean.IR.ResetReuse
/- Remark: the insertResetReuse transformation is applied before we have
   inserted `inc/dec` instructions, and perfomed lower level optimizations
   that introduce the instructions `release` and `set`. -/

/- Remark: the functions `S`, `D` and `R` defined here implement the
  corresponding functions in the paper "Counting Immutable Beans"

  Here are the main differences:
  - We use the State monad to manage the generation of fresh variable names.
  - Support for join points, and `uset` and `sset` instructions for unboxed data.
  - `D` uses the auxiliary function `Dmain`.
  - `Dmain` returns a pair `(b, found)` to avoid quadratic behavior when checking
    the last occurrence of the variable `x`.
  - Because we have join points in the actual implementation, a variable may be live even if it
    does not occur in a function body. See example at `livevars.lean`.
-/

private def mayReuse (c₁ c₂ : CtorInfo) : Bool :=
  c₁.size == c₂.size && c₁.usize == c₂.usize && c₁.ssize == c₂.ssize &&
  /- The following condition is a heuristic.
     We don't want to reuse cells from different types even when they are compatible
     because it produces counterintuitive behavior. -/
  c₁.name.getPrefix == c₂.name.getPrefix

private partial def S (w : VarId) (c : CtorInfo) : FnBody → FnBody
  | FnBody.vdecl x t v@(Expr.ctor c' ys) b   =>
    if mayReuse c c' then
      let updtCidx := c.cidx != c'.cidx
      FnBody.vdecl x t (Expr.reuse w c' updtCidx ys) b
    else
      FnBody.vdecl x t v (S w c b)
  | FnBody.jdecl j ys v b   =>
    let v' := S w c v
    if v == v' then FnBody.jdecl j ys v (S w c b)
    else FnBody.jdecl j ys v' b
  | FnBody.case tid x xType alts    => FnBody.case tid x xType <| alts.map fun alt => alt.modifyBody (S w c)
  | b =>
    if b.isTerminal then b
    else let
      (instr, b) := b.split
      instr.setBody (S w c b)

/- We use `Context` to track join points in scope. -/
abbrev M := ReaderT LocalContext (StateT Index Id)

private def mkFresh : M VarId := do
  let idx ← getModify (fun n => n + 1)
  pure { idx := idx }

private def tryS (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := do
  let w ← mkFresh
  let b' := S w c b
  if b == b' then pure b
  else pure $ FnBody.vdecl w IRType.object (Expr.reset c.size x) b'

private def Dfinalize (x : VarId) (c : CtorInfo) : FnBody × Bool → M FnBody
  | (b, true)  => pure b
  | (b, false) => tryS x c b

private def argsContainsVar (ys : Array Arg) (x : VarId) : Bool :=
  ys.any fun arg => match arg with
    | Arg.var y => x == y
    | _         => false

private def isCtorUsing (b : FnBody) (x : VarId) : Bool :=
  match b with
  | (FnBody.vdecl _ _ (Expr.ctor _ ys) _) => argsContainsVar ys x
  | _ => false

/- Given `Dmain b`, the resulting pair `(new_b, flag)` contains the new body `new_b`,
   and `flag == true` if `x` is live in `b`.

   Note that, in the function `D` defined in the paper, for each `let x := e; F`,
   `D` checks whether `x` is live in `F` or not. This is great for clarity but it
   is expensive: `O(n^2)` where `n` is the size of the function body. -/
private partial def Dmain (x : VarId) (c : CtorInfo) : FnBody → M (FnBody × Bool)
  | e@(FnBody.case tid y yType alts) => do
    let ctx ← read
    if e.hasLiveVar ctx x then do
      /- If `x` is live in `e`, we recursively process each branch. -/
      let alts ← alts.mapM fun alt => alt.mmodifyBody fun b => Dmain x c b >>= Dfinalize x c
      pure (FnBody.case tid y yType alts, true)
    else pure (e, false)
  | FnBody.jdecl j ys v b   => do
    let (b, found) ← withReader (fun ctx => ctx.addJP j ys v) (Dmain x c b)
    let (v, _ /- found' -/) ← Dmain x c v
    /- If `found' == true`, then `Dmain b` must also have returned `(b, true)` since
       we assume the IR does not have dead join points. So, if `x` is live in `j` (i.e., `v`),
       then it must also live in `b` since `j` is reachable from `b` with a `jmp`.
       On the other hand, `x` may be live in `b` but dead in `j` (i.e., `v`). -/
    pure (FnBody.jdecl j ys v b, found)
  | e => do
    let ctx ← read
    if e.isTerminal then
      pure (e, e.hasLiveVar ctx x)
    else do
      let (instr, b) := e.split
      if isCtorUsing instr x then
        /- If the scrutinee `x` (the one that is providing memory) is being
           stored in a constructor, then reuse will probably not be able to reuse memory at runtime.
           It may work only if the new cell is consumed, but we ignore this case. -/
        pure (e, true)
      else
        let (b, found) ← Dmain x c b
        /- Remark: it is fine to use `hasFreeVar` instead of `hasLiveVar`
           since `instr` is not a `FnBody.jmp` (it is not a terminal) nor it is a `FnBody.jdecl`. -/
        if found || !instr.hasFreeVar x then
          pure (instr.setBody b, found)
        else
          let b ← tryS x c b
          pure (instr.setBody b, true)

private def D (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody :=
  Dmain x c b >>= Dfinalize x c

partial def R : FnBody → M FnBody
  | FnBody.case tid x xType alts   => do
      let alts ← alts.mapM fun alt => do
        let alt ← alt.mmodifyBody R
        match alt with
        | Alt.ctor c b =>
          if c.isScalar then pure alt
          else Alt.ctor c <$> D x c b
        | _            => pure alt
      pure $ FnBody.case tid x xType alts
  | FnBody.jdecl j ys v b   => do
    let v ← R v
    let b ← withReader (fun ctx => ctx.addJP j ys v) (R b)
    pure $ FnBody.jdecl j ys v b
  | e => do
    if e.isTerminal then pure e
    else do
      let (instr, b) := e.split
      let b ← R b
      pure (instr.setBody b)

end ResetReuse

open ResetReuse

def Decl.insertResetReuse (d : Decl) : Decl :=
  match d with
  | Decl.fdecl (body := b) ..=>
    let nextIndex := d.maxIndex + 1
    let bNew      := (R b {}).run' nextIndex
    d.updateBody! bNew
  | other => other

end Lean.IR


import data.list.basic   -- basic operations on `list`
import data.option.basic -- basic operations on `option`
import data.set.basic
import data.vector
import data.vector2
import logic.function    -- function update and inverses
import aux

namespace parlang
variables {n : ℕ} {σ : Type} {ι : Type} {τ : ι → Type} [decidable_eq ι]

/-
We use the following conventions for type variables:

 `σ` -- thread internal states
 `ι` -- shared memory index
 `τ` -- shared memory type map

-/

/-- Kernel of a parallel program.

The general idea is to not have explicit expressions, but use Lean functions to compute values. What
we are explicit shared loads and stores.

Σ is constructor where the second argument may depend on the type of the first (in this case i). Can be constructed using ⟨...⟩
-/
inductive kernel {ι : Type} (σ : Type) (τ : ι → Type) : Type
| load       : (σ → (Σi:ι, (τ i → σ))) → kernel
| store      : (σ → (Σi:ι, τ i)) → kernel
| compute {} : (σ → σ) → kernel
| seq        : kernel → kernel → kernel
| ite        : (σ → bool) → kernel → kernel → kernel
| loop       : (σ → bool) → kernel → kernel
| sync {}    : kernel

infixr ` ;; `:90 := kernel.seq
open kernel

/-- Memory view -/
def memory {ι : Type} (τ : ι → Type) := Π (i : ι), τ i

namespace memory

def get (m : memory τ) (i : ι) : τ i := m i

def update (m : memory τ) (i : ι) (v : τ i) : memory τ := function.update m i v

end memory

/-- Thread state inclusing a shared memory *view*, the list of loads and stores tells what should
differ between differnet threads. -/
structure thread_state {ι : Type} (σ : Type) (τ : ι → Type) : Type :=
(tlocal : σ)
(shared : memory τ)
(loads  : set ι := ∅)
(stores : set ι := ∅)

namespace thread_state

def load (f : σ → (Σi:ι, (τ i → σ))) (t : thread_state σ τ) : thread_state σ τ :=
let ⟨i, tr⟩ := f t.tlocal in
{ tlocal := tr (t.shared.get i),
  loads := insert i t.loads,
  .. t }

def store (f : σ → (Σi:ι, τ i)) (t : thread_state σ τ) : thread_state σ τ :=
let ⟨i, v⟩ := f t.tlocal in
{ shared := t.shared.update i v,
  stores := insert i t.stores,
  .. t}

def compute (f : σ → σ) (t : thread_state σ τ) : thread_state σ τ :=
{ tlocal := f t.tlocal,
  .. t}

def sync (g : memory τ) (t : thread_state σ τ) : thread_state σ τ :=
{ shared := g,
  loads := ∅,
  stores := ∅,
  .. t}

def accesses (t : thread_state σ τ) : set ι := t.stores ∪ t.loads

end thread_state

def no_thread_active (ac : vector bool n) : bool := ¬ac.to_list.any id
def any_thread_active (ac : vector bool n) : bool := ac.to_list.any id
def all_threads_active (ac : vector bool n) : bool := ac.to_list.all id
/-- thread can only be active either in ac₁ or ac₂ -/
def ac_distinct (ac₁ ac₂ : vector bool n) : Prop := ∀ (i : fin n), ac₁.nth i = ff ∨ ac₂.nth i = ff

def ac_ge (ac' : vector bool n) (ac : vector bool n) : Prop := ∀ (t : fin n), ¬ (ac.nth t) → ¬ (ac'.nth t)
instance : has_le (vector bool n) := ⟨ac_ge⟩

/-- shared program state -/
structure state {ι : Type} (n : ℕ) (σ : Type) (τ : ι → Type) : Type :=
(threads : vector (thread_state σ τ) n)

namespace state

def map_threads (f : thread_state σ τ → thread_state σ τ) (s : state n σ τ) : state n σ τ :=
{ threads := s.threads.map f, ..s }

-- we generally don't want to unfold this if possible
-- this would for example happen when you do cases in (exec_state (compute f) ...)
-- TODO: rename this to mat? It would shorten a lot of names
@[irreducible]
def map_active_threads (ac : vector bool n) (f : thread_state σ τ → thread_state σ τ) (s : state n σ τ) : state n σ τ :=
{ threads := (s.threads.map₂ (λ t (a : bool), if a then f t else t) ac), ..s }

def active_threads (ac : vector bool n) (s : state n σ τ) : list (thread_state σ τ) :=
((s.threads.map₂ prod.mk ac).to_list.filter (λ c : (thread_state σ τ × bool), c.2)).map (λ ⟨t, a⟩, t)

-- case 1: no thread changed ι and shadows must be equal at ι
-- case 2: thread t changed ι and all other threads must not access ι
def syncable (s : state n σ τ) (m : memory τ) : Prop :=
∀i:ι,
  (∀ tid, i ∉ (s.threads.nth tid).stores ∧ m i = (s.threads.nth tid).shared i) ∨
  (∃ tid, i ∈ (s.threads.nth tid).stores ∧ m i = (s.threads.nth tid).shared i ∧
    (∀ tid', tid ≠ tid' → i ∉ (s.threads.nth tid').accesses))

def precedes (s u : state n σ τ) : Prop :=
∀ (t : thread_state σ τ × thread_state σ τ), t ∈ (s.threads.map₂ prod.mk u.threads) → t.1.stores ⊆ t.2.stores ∧ t.1.loads ⊆ t.2.loads

end state

/-- If condition *f* evaluates to *tt*, the thread is deactivated -/
@[irreducible]
def deactivate_threads (f : σ → bool) (ac : vector bool n) (s : state n σ τ) : vector bool n :=
ac.map₂ (λ a (ts : thread_state σ τ), (bnot ∘ f) ts.tlocal && a) s.threads

def subkernel (q : kernel σ τ) : kernel σ τ → Prop
| (seq k₁ k₂) := k₁ = q ∨ k₂ = q ∨ subkernel k₁ ∨ subkernel k₂
| (ite c th el) := th = q ∨ el = q ∨ subkernel th ∨ subkernel el
| (loop c body) := body = q ∨ subkernel body
| k := k = q

/-- Execute a kernel on a shared state, i.e. a list of threads -/
inductive exec_state {n : ℕ} : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop
| load (f) (s : state n σ τ) (ac : vector bool n) :
  exec_state (load f) ac s (s.map_active_threads ac $ thread_state.load f)
| store (f) (s : state n σ τ) (ac : vector bool n) :
  exec_state (store f) ac s (s.map_active_threads ac $ thread_state.store f)
| compute (f : σ → σ) (s : state n σ τ) (ac : vector bool n) :
  exec_state (compute f) ac s (s.map_active_threads ac $ thread_state.compute f)
| sync_all (s : state n σ τ) (ac : vector bool n) (m : memory τ) (hs : s.syncable m)
  (ha : all_threads_active ac) :
  exec_state sync ac s (s.map_threads $ thread_state.sync m)
| sync_none (s : state n σ τ) (ac : vector bool n) (h : no_thread_active ac) :
  exec_state sync ac s s
| seq (s t u : state n σ τ) (ac : vector bool n) (k₁ k₂ : kernel σ τ) :
  exec_state k₁ ac s t → exec_state k₂ ac t u → exec_state (seq k₁ k₂) ac s u
  -- in the then-branch we deactivate the threads where the condition is false and similar for else
| ite (s t u : state n σ τ) (ac : vector bool n) (f : σ → bool) (k₁ k₂ : kernel σ τ) :
  exec_state k₁ (deactivate_threads (bnot ∘ f) ac s) s t →
  exec_state k₂ (deactivate_threads f ac s) t u →
  exec_state (ite f k₁ k₂) ac s u
| loop_stop (s : state n σ τ) (ac : vector bool n) (f : σ → bool) (k : kernel σ τ) :
  no_thread_active (deactivate_threads (bnot ∘ f) ac s) →
  exec_state (loop f k) ac s s
| loop_step (s t u : state n σ τ) (ac : vector bool n) (f : σ → bool) (k : kernel σ τ) :
  any_thread_active (deactivate_threads (bnot ∘ f) ac s) →
  exec_state k (deactivate_threads (bnot ∘ f) ac s) s t →
  exec_state (loop f k) (deactivate_threads (bnot ∘ f) ac s) t u →
  exec_state (loop f k) ac s u

def kernel_transform_func (k) (f) (n) (ac) : Prop := ∀ (s u : state n σ τ), exec_state k ac s u ↔ (u = s.map_active_threads ac f)

def contains_sync : kernel σ τ → Prop
| (sync) := true
| (seq k₁ k₂) := contains_sync k₁ ∨ contains_sync k₂
| (load _) := false
| (store _) := false
| (compute _) := false
| (ite c k₁ k₂) := contains_sync k₁ ∨ contains_sync k₂
| (loop c k) := contains_sync k

inductive program {ι : Type} (σ : Type) (τ : ι → Type)
| intro (f : memory τ → ℕ) (k : kernel σ τ) : program

def state_initializer := ℕ → σ

@[reducible]
def init_state (init : ℕ → σ) (f : memory τ → ℕ) (m : memory τ) : state (f m) σ τ :=
{ threads := (vector.range (f m)).map (λ n, { tlocal := init n, shared := m, loads := ∅, stores := ∅ })}

inductive exec_prog : (ℕ → σ) → program σ τ → memory τ → memory τ → Prop
| intro (k : kernel σ τ) (f : memory τ → ℕ) (a b : memory τ) (init : ℕ → σ) (s' : state (f a) σ τ) (hsync : s'.syncable b)
  (he : exec_state k (vector.repeat tt (f a)) (init_state init f a) s') :
  exec_prog init (program.intro f k) a b

def list_to_kernel_seq (ks : list (kernel σ τ)) : kernel σ τ := ks.foldl (λ k₁ k₂, k₁ ;; k₂) (kernel.compute id)

end parlang


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.declaration init.meta.exceptional init.data.option.basic
import init.meta.rb_map

/-- An __environment__ contains all of the declarations and notation that have been defined so far.   -/
meta constant environment : Type

namespace environment
/--
Consider a type `ψ` which is an inductive datatype using a single constructor `mk (a : α) (b : β) : ψ`.
Lean will automatically make two projection functions `a : ψ → α`, `b : ψ → β`.
Lean tags these declarations as __projections__.
This helps the simplifier / rewriter not have to expand projectors.
Eg `a (mk x y)` will automatically reduce to `x`.
If you `extend` a structure, all of the projections on the parent will also be created for the child.
Projections are also treated differently in the VM for efficiency.

Note that projections have nothing to do with the dot `mylist.map` syntax.

You can find out if a declaration is a projection using `environment.is_projection` which returns `projection_info`.

Data for a projection declaration:
- `cname`    is the name of the constructor associated with the projection.
- `nparams`  is the number of constructor parameters. Eg `and.intro` has two type parameters.
- `idx`      is the parameter being projected by this projection.
- `is_class` is tt iff this is a typeclass projection.

### Examples:

- `and.right` is a projection with ``{cname := `and.intro, nparams := 2, idx := 1, is_class := ff}``
- `ordered_ring.neg` is a projection with ``{cname := `ordered_ring.mk, nparams := 1, idx := 5, is_class := tt}``.

-/
structure projection_info :=
(cname : name)
(nparams : nat)
(idx : nat)
(is_class : bool)

/-- A marking on the binders of structures and inductives indicating
   how this constructor should mark its parameters.

       inductive foo
       | one {} : foo -> foo   -- relaxed_implicit
       | two ( ) : foo -> foo  -- explicit
       | two [] : foo -> foo   -- implicit
       | three : foo -> foo    -- relaxed implicit (default)
-/
inductive implicit_infer_kind | implicit | relaxed_implicit | none
instance implicit_infer_kind.inhabited : inhabited implicit_infer_kind := ⟨implicit_infer_kind.implicit⟩

/-- One introduction rule in an inductive declaration -/
meta structure intro_rule :=
(constr : name)
(type : expr)
(infer : implicit_infer_kind := implicit_infer_kind.implicit)

/-- Create a standard environment using the given trust level -/
meta constant mk_std          : nat → environment
/-- Return the trust level of the given environment -/
meta constant trust_lvl       : environment → nat
/-- Add a new declaration to the environment -/
meta constant add             : environment → declaration → exceptional environment
/-- make declaration `n` protected -/
meta constant mk_protected   : environment → name → environment

/-- add declaration `d` and make it protected -/
meta def add_protected (env : environment) (d : declaration) : exceptional environment := do
env ← env.add d,
pure $ env.mk_protected d.to_name

/-- check if `n` is the name of a protected declaration -/
meta constant is_protected    : environment → name → bool
/-- Retrieve a declaration from the environment -/
meta constant get             : environment → name → exceptional declaration
meta def      contains (env : environment) (d : name) : bool :=
match env.get d with
| exceptional.success _      := tt
| exceptional.exception _ := ff
end

meta constant add_defn_eqns (env : environment) (opt : options)
  (lp_params : list name) (params : list expr) (sig : expr)
  (eqns : list (list (expr ff) × expr)) (is_meta : bool) : exceptional environment

/-- Register the given name as a namespace, making it available to the `open` command -/
meta constant add_namespace   : environment → name → environment
/-- Mark a namespace as open -/
meta constant mark_namespace_as_open : environment -> name -> environment
/-- Modify the environment as if `open %%name` had been parsed -/
meta constant execute_open : environment -> name -> environment
/-- Retrieve all registered namespaces -/
meta constant get_namespaces : environment -> list name
/-- Return tt iff the given name is a namespace -/
meta constant is_namespace    : environment → name → bool
/-- Add a new inductive datatype to the environment
   name, universe parameters, number of parameters, type, constructors (name and type), is_meta -/
meta constant add_inductive (env : environment)
  (n : name) (levels : list name) (num_params : nat) (type : expr)
  (intros : list (name × expr)) (is_meta : bool) : exceptional environment
/-- Add a new general inductive declaration to the environment.
  This has the same effect as a `inductive` in the file, including generating
  all the auxiliary definitions, as well as triggering mutual/nested inductive
  compilation, by contrast to `environment.add_inductive` which only adds the
  core axioms supported by the kernel.

  The `inds` argument should be a list of inductives in the mutual family.
  The first argument is a pair of the name of the type being constructed
  and the type of this inductive family (not including the params).
  The second argument is a list of intro rules, specified by a name, an
  `implicit_infer_kind` giving the implicitness of the params for this constructor,
  and an expression with the type of the constructor (not including the params).
-/
meta constant add_ginductive (env : environment) (opt : options)
  (levels : list name) (params : list expr)
  (inds : list ((name × expr) × list intro_rule))
  (is_meta : bool) : exceptional environment
/-- Return tt iff the given name is an inductive datatype -/
meta constant is_inductive    : environment → name → bool
/-- Return tt iff the given name is a constructor -/
meta constant is_constructor  : environment → name → bool
/-- Return tt iff the given name is a recursor -/
meta constant is_recursor     : environment → name → bool
/-- Return tt iff the given name is a recursive inductive datatype -/
meta constant is_recursive    : environment → name → bool
/-- Return the name of the inductive datatype of the given constructor. -/
meta constant inductive_type_of : environment → name → option name
/-- Return the constructors of the inductive datatype with the given name -/
meta constant constructors_of : environment → name → list name
/-- Return the recursor of the given inductive datatype -/
meta constant recursor_of     : environment → name → option name
/-- Return the number of parameters of the inductive datatype -/
meta constant inductive_num_params : environment → name → nat
/-- Return the number of indices of the inductive datatype -/
meta constant inductive_num_indices : environment → name → nat
/-- Return tt iff the inductive datatype recursor supports dependent elimination -/
meta constant inductive_dep_elim : environment → name → bool
/-- Functionally equivalent to `is_inductive`.

Technically, this works by checking if the name is in the ginductive environment
extension which is outside the kernel, whereas `is_inductive` works by looking at the kernel extension.
But there are no `is_inductive`s which are not `is_ginductive`.
 -/
meta constant is_ginductive : environment → name → bool
/-- See the docstring for `projection_info`. -/
meta constant is_projection : environment → name → option projection_info
/-- Fold over declarations in the environment. -/
meta constant fold {α :Type} : environment → α → (declaration → α → α) → α
/-- `relation_info env n` returns some value if n is marked as a relation in the given environment.
   the tuple contains: total number of arguments of the relation, lhs position and rhs position. -/
meta constant relation_info : environment → name → option (nat × nat × nat)
/-- `refl_for env R` returns the name of the reflexivity theorem for the relation R -/
meta constant refl_for : environment → name → option name
/-- `symm_for env R` returns the name of the symmetry theorem for the relation R -/
meta constant symm_for : environment → name → option name
/-- `trans_for env R` returns the name of the transitivity theorem for the relation R -/
meta constant trans_for : environment → name → option name
/-- `decl_olean env d` returns the name of the .olean file where d was defined.
   The result is none if d was not defined in an imported file. -/
meta constant decl_olean : environment → name → option string
/-- `decl_pos env d` returns the source location of d if available. -/
meta constant decl_pos : environment → name → option pos
/-- `decl_pos env d` returns the name of a declaration that d inherits
noncomputability from, or `none` if it is computable.

Note that this also returns `none` on `axiom`s and `constant`s. These can be detected by using
`environment.get_decl` and `declaration.is_axiom` and `declaration.is_constant`. -/
meta constant decl_noncomputable_reason : environment → name → option name
/-- Return the fields of the structure with the given name, or `none` if it is not a structure -/
meta constant structure_fields : environment → name → option (list name)
/-- `get_class_attribute_symbols env attr_name` return symbols
   occurring in instances of type classes tagged with the attribute `attr_name`.
   Example: [algebra] -/
meta constant get_class_attribute_symbols : environment → name → name_set
/-- The fingerprint of the environment is a hash formed from all of the declarations in the environment. -/
meta constant fingerprint : environment → nat

/-- Gets the equation lemmas for the declaration `n`. -/
meta constant get_eqn_lemmas_for (env : environment) (n : name) : list name
/-- Gets the equation lemmas for the declaration `n`, including lemmas for match statements, etc. -/
meta constant get_ext_eqn_lemmas_for (env : environment) (n : name) : list name
/--
Adds the equation lemma `n`.
It is added for the declaration `t.pi_codomain.get_app_fn.const_name` where `t` is the type of the equation lemma.
-/
meta constant add_eqn_lemma (env : environment) (n : name) : environment

open expr

meta constant unfold_untrusted_macros : environment → expr → expr
meta constant unfold_all_macros : environment → expr → expr

meta def is_constructor_app (env : environment) (e : expr) : bool :=
is_constant (get_app_fn e) && is_constructor env (const_name (get_app_fn e))

meta def is_refl_app (env : environment) (e : expr) : option (name × expr × expr) :=
match (refl_for env (const_name (get_app_fn e))) with
| (some n) :=
    if get_app_num_args e ≥ 2
    then some (n, app_arg (app_fn e), app_arg e)
    else none
| none   := none
end

/-- Return true if 'n' has been declared in the current file -/
meta def in_current_file (env : environment) (n : name) : bool :=
(env.decl_olean n).is_none && env.contains n && (n ∉ [``quot, ``quot.mk, ``quot.lift, ``quot.ind])

meta def is_definition (env : environment) (n : name) : bool :=
match env.get n with
| exceptional.success (declaration.defn _ _ _ _ _ _) := tt
| _                                                  := ff
end

end environment

meta instance : has_repr environment :=
⟨λ e, "[environment]"⟩

meta instance : inhabited environment :=
⟨environment.mk_std 0⟩


import category_theory.limits.shapes.binary_products
import category_theory.limits.preserves.shapes.binary_products
import category_theory.adjunction
import category_theory.monad.adjunction
import category_theory.adjunction.fully_faithful
import category_theory.closed.cartesian
import category.adjunction

universes v₁ v₂ u₁ u₂

namespace category_theory

open limits category

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

def coyoneda.ext {X Y : C} (p : Π {Z : C}, (X ⟶ Z) ≃ (Y ⟶ Z))
  (n : Π {Z Z' : C} (f : Z ⟶ Z') (g : X ⟶ Z), p (g ≫ f) = p g ≫ f) : X ≅ Y :=
{ hom := p.symm (𝟙 Y),
  inv := p (𝟙 X),
  hom_inv_id' := by rw [← p.injective.eq_iff, n, p.apply_symm_apply, id_comp],
  inv_hom_id' := by rw [← n, id_comp, equiv.apply_symm_apply] }

class in_subcategory (A : C) :=
(witness : D)
(iso : i.obj witness ≅ A)

def witness_in (A : C) [in_subcategory i A] : D := in_subcategory.witness.{v₁} i A
def witness_iso (A : C) [in_subcategory i A] : i.obj (witness_in i A) ≅ A := in_subcategory.iso.

class in_subcategory' [ir : is_right_adjoint i] (A : C) :=
( returning : is_iso (ir.adj.unit.app A) )

def containment_iso (A : C) [ir : is_right_adjoint i] [h : in_subcategory' i A] : A ≅ i.obj ((left_adjoint i).obj A) :=
begin
  haveI := h.returning,
  exact as_iso (ir.adj.unit.app A),
end
variable {i}

instance inclusion_is_in (B : D) : in_subcategory i (i.obj B) :=
{ witness := B,
  iso := iso.refl _ }

noncomputable
instance inclusion_is_in' (B : D) [ir : reflective i] : in_subcategory' i (i.obj B) :=
{ returning :=
  begin
    haveI := nat_iso.is_iso_app_of_is_iso ir.adj.counit B,
    have : ir.adj.unit.app (i.obj B) ≫ i.map (ir.adj.counit.app B) = 𝟙 (i.obj B) := ir.adj.right_triangle_components,
    refine ⟨i.map (ir.adj.counit.app B), ir.adj.right_triangle_components, _⟩,
    dsimp,
    rw [← cancel_mono (i.map (is_right_adjoint.adj.counit.app B)), assoc, this, comp_id, id_comp],
    apply is_iso.mono_of_iso,
  end }

def unit_iso_of_split_mono [ir : reflective i] (A : C) [split_mono (ir.adj.unit.app A)] : is_iso (ir.adj.unit.app A) :=
begin
  let h : i.obj (ir.left.obj A) ⟶ A := retraction (ir.adj.unit.app A),
  haveI : is_iso (ir.adj.unit.app (i.obj (ir.left.obj A))) := in_subcategory'.returning,
  haveI : split_epi h := ⟨ir.adj.unit.app A, split_mono.id (ir.adj.unit.app A)⟩,
  suffices : epi (ir.adj.unit.app A),
    refine ⟨h, split_mono.id (ir.adj.unit.app A), _⟩,
    resetI,
    dsimp,
    erw [← cancel_epi (ir.adj.unit.app A), split_mono.id_assoc (ir.adj.unit.app A), comp_id],
  suffices : epi (ir.adj.unit.app _ ≫ i.map (ir.left.map h)),
    erw [← ir.adj.unit.naturality h, functor.id_map] at this,
    resetI,
    apply epi_of_epi h,
  apply epi_comp,
end

-- Some of the stuff here doesn't need reflectiveness, need to untangle what assumptions are actually used
noncomputable
def in_subcategory_of_has_iso [ir : reflective i] (A : C) (B : D) (h : i.obj B ≅ A) : in_subcategory' i A :=
{ returning :=
  begin
    apply unit_iso_of_split_mono _,
    refine ⟨i.map ((ir.adj.hom_equiv _ _).symm h.inv) ≫ h.hom, _⟩,
    simp,
  end }

@[reducible]
def equiv_homset_left_of_iso
  {X X' : C} (Y : C) (i : X ≅ X') :
  (X ⟶ Y) ≃ (X' ⟶ Y) :=
{ to_fun := λ f, i.inv ≫ f,
  inv_fun := λ f, i.hom ≫ f,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }.

@[reducible]
def equiv_homset_right_of_iso
  (X : C) {Y Y' : C} (i : Y ≅ Y') :
  (X ⟶ Y) ≃ (X ⟶ Y') :=
{ to_fun := λ f, f ≫ i.hom,
  inv_fun := λ f, f ≫ i.inv,
  left_inv := λ f, by simp,
  right_inv := λ f, by simp }.

variable (i)
noncomputable
def biject_inclusion [ir : reflective i] {A B : C} [in_subcategory' i B] : (A ⟶ B) ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) :=
calc (A ⟶ B) ≃ (A ⟶ i.obj ((left_adjoint i).obj B)) : equiv_homset_right_of_iso _ (containment_iso _ _)
    ... ≃ ((left_adjoint i).obj A ⟶ (left_adjoint i).obj B) : (ir.adj.hom_equiv _ _).symm
    ... ≃ (i.obj ((left_adjoint i).obj A) ⟶ i.obj ((left_adjoint i).obj B)) : equiv_of_fully_faithful i
    ... ≃ (i.obj ((left_adjoint i).obj A) ⟶ B) : equiv_homset_right_of_iso _ (containment_iso _ _).symm
variable {i}

lemma biject_inclusion_natural [ir : reflective i] {A B B' : C} [h : in_subcategory' i B] [h' : in_subcategory' i B'] (f : A ⟶ B) (g : B ⟶ B') :
  biject_inclusion i (f ≫ g) = biject_inclusion i f ≫ g :=
begin
  dsimp [biject_inclusion, containment_iso],
  haveI := h'.returning,
  haveI := h.returning,
  have : i.map
        (((is_right_adjoint.adj.hom_equiv A ((left_adjoint i).obj B')).symm)
           ((f ≫ g) ≫ is_right_adjoint.adj.unit.app B')) ≫
      inv (is_right_adjoint.adj.unit.app B') = (i.map
           (((is_right_adjoint.adj.hom_equiv A ((left_adjoint i).obj B)).symm)
              (f ≫ is_right_adjoint.adj.unit.app B)) ≫
         inv (is_right_adjoint.adj.unit.app B)) ≫
      g ↔ _ = _ := (as_iso (ir.adj.unit.app B')).comp_inv_eq,
  convert this.2 _, -- this should not be necessary
  clear this,
  dsimp [as_iso_hom],
  erw [assoc, assoc, ir.adj.unit.naturality, assoc, (as_iso _).inv_hom_id_assoc, functor.comp_map, ← functor.map_comp],
  rw [← ir.adj.hom_equiv_naturality_right_symm, assoc], refl,
end .

lemma biject_inclusion_natural_left [ir : reflective i] {A A' B : C} [h : in_subcategory' i B] (f : A ⟶ A') (g : A' ⟶ B) :
  biject_inclusion i (f ≫ g) = i.map ((left_adjoint i).map f) ≫ biject_inclusion i g :=
begin
  dsimp [biject_inclusion],
  erw [← i.map_comp_assoc, ← ir.adj.hom_equiv_naturality_left_symm, assoc],
end

lemma biject_inclusion_symm_id_eq [ir : reflective i] (A : C) :
  (biject_inclusion i).symm (𝟙 (i.obj ((left_adjoint i).obj A))) = ir.adj.unit.app A :=
begin
  rw equiv.symm_apply_eq,
  dsimp [biject_inclusion, containment_iso],
  rw [ir.adj.hom_equiv_counit],
  let η := ir.adj.unit,
  let ε := ir.adj.counit,
  let L := left_adjoint i,
  have : 𝟙 (i.obj ((left_adjoint i).obj A)) = _ ≫ inv (is_right_adjoint.adj.unit.app (i.obj ((left_adjoint i).obj A))) ↔ _ = _ := (as_iso (is_right_adjoint.adj.unit.app (i.obj ((left_adjoint i).obj A)))).eq_comp_inv,
  rw this, clear this,
  rw [id_comp, as_iso_hom],
  change η.app (i.obj (L.obj A)) = i.map (L.map (η.app A ≫ η.app (i.obj (L.obj A))) ≫ ε.app (L.obj (i.obj (L.obj A)))),
  rw [L.map_comp, assoc],
  haveI := nat_iso.is_iso_app_of_is_iso ε (L.obj A),
  erw [ir.adj.left_triangle_components, comp_id, ← cancel_mono (i.map (ε.app (L.obj A))), ir.adj.right_triangle_components,
       ← i.map_comp, ir.adj.left_triangle_components, i.map_id],
end

lemma biject_inclusion_is_comp_unit [ir : reflective i] {A B : C} [h : in_subcategory' i B] (f : i.obj ((left_adjoint i).obj A) ⟶ B) :
  (biject_inclusion i).symm f = ir.adj.unit.app _ ≫ f :=
by rw [← biject_inclusion_symm_id_eq A, (biject_inclusion i).symm_apply_eq,
       biject_inclusion_natural _ _, equiv.apply_symm_apply, id_comp]

variables [has_finite_products.{v₁} C] [has_finite_products.{v₁} D] [cartesian_closed C] (i)

class exponential_ideal extends reflective i :=
[ strength (A) {B} [in_subcategory' i B] : in_subcategory' i (A ⟹ B) ]

noncomputable def exponential_ideal_of [z : reflective i]
  (h : ∀ (A : C) (B : D), in_subcategory' i (A ⟹ i.obj B)) : exponential_ideal i :=
{ strength := λ A B inst,
  begin
    resetI,
    let ir : is_right_adjoint i := by apply_instance,
    let L := ir.left,
    let η := ir.adj.unit,
    haveI := h A (L.obj B),
    let i₁ : B ≅ i.obj (L.obj B) := containment_iso i B,
    let i₂ : A ⟹ i.obj (L.obj B) ≅ i.obj (L.obj (A ⟹ (i.obj (L.obj B)))) := containment_iso i (A ⟹ i.obj (L.obj B)),
    let : A ⟹ B ≅ i.obj (L.obj (A ⟹ B)),
      apply (exp A).map_iso i₁ ≪≫ i₂ ≪≫ (exp A ⋙ L ⋙ i).map_iso i₁.symm,
    refine ⟨_⟩,
    convert is_iso.of_iso this,
    change η.app (A ⟹ B) =
      (exp _).map (containment_iso _ _).hom ≫ η.app _ ≫ i.map (L.map ((exp _).map (containment_iso _ _).inv)),
    erw η.naturality_assoc,
    change η.app (A ⟹ B) = η.app (A ⟹ B) ≫ (exp A ⋙ L ⋙ _).map _ ≫ (exp A ⋙ L ⋙ _).map _,
    rw [← (exp A ⋙ L ⋙ _).map_comp, iso.hom_inv_id, functor.map_id],
    erw comp_id,
  end,
  ..z }

variables [exponential_ideal i]

noncomputable
def bijection (A B : C) (C' : D) : ((left_adjoint i).obj (A ⨯ B) ⟶ C') ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ C') :=
calc _ ≃ (A ⨯ B ⟶ i.obj C') : _inst_6.to_reflective.adj.hom_equiv _ _
... ≃ (B ⨯ A ⟶ i.obj C') : equiv_homset_left_of_iso _ (limits.prod.braiding _ _)
... ≃ (A ⟶ B ⟹ i.obj C') : (exp.adjunction _).hom_equiv _ _
... ≃ (i.obj ((left_adjoint i).obj A) ⟶ B ⟹ i.obj C') :
  begin
    apply biject_inclusion i,
    apply exponential_ideal.strength,
  end
... ≃ (B ⨯ i.obj ((left_adjoint i).obj A) ⟶ i.obj C') : ((exp.adjunction _).hom_equiv _ _).symm
... ≃ (i.obj ((left_adjoint i).obj A) ⨯ B ⟶ i.obj C') : equiv_homset_left_of_iso _ (limits.prod.braiding _ _)
... ≃ (B ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj C') : (exp.adjunction _).hom_equiv _ _
... ≃ (i.obj ((left_adjoint i).obj B) ⟶ i.obj ((left_adjoint i).obj A) ⟹ i.obj C') :
  begin
    apply biject_inclusion _,
    apply exponential_ideal.strength,
  end
... ≃ (i.obj ((left_adjoint i).obj A) ⨯ i.obj ((left_adjoint i).obj B) ⟶ i.obj C') : ((exp.adjunction _).hom_equiv _ _).symm
... ≃ (i.obj ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B) ⟶ i.obj C') : equiv_homset_left_of_iso _
  begin
    apply (as_iso (prod_comparison _ _ _)).symm,
    haveI : preserves_limits i := _inst_6.to_reflective.adj.right_adjoint_preserves_limits,
    apply_instance,
  end
... ≃ ((left_adjoint i).obj A ⨯ (left_adjoint i).obj B ⟶ C') : (equiv_of_fully_faithful _).symm

variables {i}

lemma comp_inv_eq {X Y Z : C} (f : X ⟶ Y) (g : Z ⟶ Y) (h : Z ⟶ X) [is_iso f] :
  g ≫ inv f = h ↔ g = h ≫ f :=
(as_iso f).comp_inv_eq.

-- @[reassoc] lemma prod_comparison_natural (F : C ⥤ D) {A A' B B' : C} (f : A ⟶ A') (g : B ⟶ B') :
--   F.map (prod.map f g) ≫ prod_comparison F A' B' = prod_comparison F A B ≫ prod.map (F.map f) (F.map g) :=

lemma bijection_id (A B : C) : (bijection i A B _).symm (𝟙 _) = prod_comparison _ _ _ :=
begin
  dsimp [bijection],
  -- rw [equiv.symm_symm, equiv.symm_symm, equiv.symm_symm],
  -- dsimp [equiv_of_fully_faithful],
  rw [i.map_id, comp_id, biject_inclusion_is_comp_unit, biject_inclusion_is_comp_unit],
  let ir : is_right_adjoint i := by apply_instance,
  let L := ir.left,
  let adj : L ⊣ i := ir.adj,
  let η : _ ⟶ L ⋙ i := adj.unit,
  let ε : i ⋙ L ⟶ _ := adj.counit,
  change ((adj.hom_equiv (A ⨯ B) (L.obj A ⨯ L.obj B)).symm)
      (prod.lift limits.prod.snd limits.prod.fst ≫
         cartesian_closed.uncurry (η.app A ≫
              cartesian_closed.curry (prod.lift limits.prod.snd limits.prod.fst ≫
                   cartesian_closed.uncurry (η.app B ≫ cartesian_closed.curry _)))) =
    prod_comparison L A B,
  rw [uncurry_natural_left, uncurry_curry, uncurry_natural_left, uncurry_curry,
      ← adjunction.eq_hom_equiv_apply, prod.lift_map_assoc, prod.lift_map_assoc,
      comp_id, comp_id, ← assoc, comp_inv_eq, adjunction.hom_equiv_unit, assoc],
  apply prod.hom_ext,
  rw [assoc, prod.lift_fst, prod.lift_snd, assoc, assoc, prod_comparison, prod_comparison,
      prod.lift_fst, ← i.map_comp, prod.lift_fst],
  apply η.naturality,
  rw [assoc, prod.lift_snd, prod.lift_fst_assoc, assoc, assoc, prod_comparison,
      prod_comparison, prod.lift_snd, ← i.map_comp, prod.lift_snd],
  apply η.naturality,
end .

lemma bijection_natural (A B : C) (C' C'' : D) (f : ((left_adjoint i).obj (A ⨯ B) ⟶ C')) (g : C' ⟶ C'') : bijection i _ _ _ (f ≫ g) = bijection i _ _ _ f ≫ g :=
begin
  have : i.preimage (i.map g) = g := preimage_map g,
  conv_rhs {congr, skip, rw ← this},
  dsimp [bijection],
  rw [← preimage_comp, assoc, ← adjunction.hom_equiv_naturality_right_symm,
      is_right_adjoint.adj.hom_equiv_naturality_right, ← assoc,
      (exp.adjunction B).hom_equiv_naturality_right, ← biject_inclusion_natural _ _,
      ← (exp.adjunction (i.obj _)).hom_equiv_naturality_right, assoc,
      ← (exp.adjunction B).hom_equiv_naturality_right_symm, ← biject_inclusion_natural _ _],
end

open limits.prod

noncomputable
def preserves_pair_of_exponential_ideal (A B : C) : preserves_limit (pair.{v₁} A B) (is_right_adjoint.left i) :=
begin
  let ir : is_right_adjoint i := by apply_instance,
  let L := ir.left,
  let : L.obj (A ⨯ B) ≅ L.obj A ⨯ L.obj B := coyoneda.ext (λ Z, bijection i A B _) (λ _ _ _ _, bijection_natural _ _ _ _ _ _),
  have equate : prod_comparison L A B = this.hom := (bijection_id A B).symm,
  have : is_iso (prod_comparison L A B),
    rw equate, apply_instance,
  exactI preserves_pair.of_iso_comparison _ _ _,
end

variable (i)
noncomputable
def preserves_binary_products_of_exponential_ideal : preserves_limits_of_shape (discrete walking_pair) (is_right_adjoint.left i) :=
{ preserves_limit := λ K,
  begin
    apply preserves_limit_of_iso_diagram _ (diagram_iso_pair K).symm,
    apply preserves_pair_of_exponential_ideal,
  end }
end category_theory


/-
Copyright (c) 2021 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import category_theory.adjunction.fully_faithful
import category_theory.sites.plus
import category_theory.limits.concrete_category
import category_theory.concrete_category.elementwise

/-!

# Sheafification

We construct the sheafification of a presheaf over a site `C` with values in `D` whenever
`D` is a concrete category for which the forgetful functor preserves the appropriate (co)limits
and reflects isomorphisms.

We generally follow the approach of https://stacks.math.columbia.edu/tag/00W1

-/

namespace category_theory

open category_theory.limits opposite

universes w v u
variables {C : Type u} [category.{v} C] {J : grothendieck_topology C}
variables {D : Type w} [category.{max v u} D]

section
variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

/-- A concrete version of the multiequalizer, to be used below. -/
@[nolint has_nonempty_instance]
def meq {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) :=
{ x : Π (I : S.arrow), P.obj (op I.Y) //
  ∀ (I : S.relation), P.map I.g₁.op (x I.fst) = P.map I.g₂.op (x I.snd) }
end

namespace meq

variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

instance {X} (P : Cᵒᵖ ⥤ D) (S : J.cover X) : has_coe_to_fun (meq P S)
  (λ x, Π (I : S.arrow), P.obj (op I.Y)) := ⟨λ x, x.1⟩

@[ext]
lemma ext {X} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x y : meq P S)
  (h : ∀ I : S.arrow, x I = y I) : x = y := subtype.ext $ funext $ h

lemma condition {X} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (I : S.relation) :
  P.map I.g₁.op (x ((S.index P).fst_to I)) = P.map I.g₂.op (x ((S.index P).snd_to I)) := x.2 _

/-- Refine a term of `meq P T` with respect to a refinement `S ⟶ T` of covers. -/
def refine {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (x : meq P T) (e : S ⟶ T) :
  meq P S :=
⟨λ I, x ⟨I.Y, I.f, (le_of_hom e) _ I.hf⟩,
  λ I, x.condition ⟨I.Y₁, I.Y₂, I.Z, I.g₁, I.g₂, I.f₁, I.f₂,
    (le_of_hom e) _ I.h₁, (le_of_hom e) _ I.h₂, I.w⟩⟩

@[simp]
lemma refine_apply {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (x : meq P T) (e : S ⟶ T)
  (I : S.arrow) : x.refine e I = x ⟨I.Y, I.f, (le_of_hom e) _ I.hf⟩ := rfl

/-- Pull back a term of `meq P S` with respect to a morphism `f : Y ⟶ X` in `C`. -/
def pullback {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X) :
  meq P ((J.pullback f).obj S) :=
⟨λ I, x ⟨_,I.f ≫ f, I.hf⟩, λ I, x.condition
  ⟨I.Y₁, I.Y₂, I.Z, I.g₁, I.g₂, I.f₁ ≫ f, I.f₂ ≫ f, I.h₁, I.h₂, by simp [reassoc_of I.w]⟩ ⟩

@[simp]
lemma pullback_apply {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X)
  (I : ((J.pullback f).obj S).arrow) : x.pullback f I = x ⟨_, I.f ≫ f, I.hf⟩ := rfl

@[simp]
lemma pullback_refine {Y X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X} (h : S ⟶ T)
  (f : Y ⟶ X) (x : meq P T) : (x.pullback f).refine
  ((J.pullback f).map h) = (refine x h).pullback _ := rfl

/-- Make a term of `meq P S`. -/
def mk {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) : meq P S :=
⟨λ I, P.map I.f.op x, λ I, by { dsimp, simp only [← comp_apply, ← P.map_comp, ← op_comp, I.w] }⟩

lemma mk_apply {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) (I : S.arrow) :
  mk S x I = P.map I.f.op x := rfl

variable [preserves_limits (forget D)]

/-- The equivalence between the type associated to `multiequalizer (S.index P)` and `meq P S`. -/
noncomputable
def equiv {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) [has_multiequalizer (S.index P)] :
  (multiequalizer (S.index P) : D) ≃ meq P S :=
limits.concrete.multiequalizer_equiv _

@[simp]
lemma equiv_apply {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} [has_multiequalizer (S.index P)]
  (x : multiequalizer (S.index P)) (I : S.arrow) :
equiv P S x I = multiequalizer.ι (S.index P) I x := rfl

@[simp]
lemma equiv_symm_eq_apply {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} [has_multiequalizer (S.index P)]
  (x : meq P S) (I : S.arrow) : multiequalizer.ι (S.index P) I ((meq.equiv P S).symm x) = x I :=
begin
  let z := (meq.equiv P S).symm x,
  rw ← equiv_apply,
  simp,
end

end meq

namespace grothendieck_topology

namespace plus

variables [concrete_category.{max v u} D]

local attribute [instance]
  concrete_category.has_coe_to_sort
  concrete_category.has_coe_to_fun

variable [preserves_limits (forget D)]
variables [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
variables [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]

noncomputable theory

/-- Make a term of `(J.plus_obj P).obj (op X)` from `x : meq P S`. -/
def mk {X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) : (J.plus_obj P).obj (op X) :=
colimit.ι (J.diagram P X) (op S) ((meq.equiv P S).symm x)

lemma res_mk_eq_mk_pullback {Y X : C} {P : Cᵒᵖ ⥤ D} {S : J.cover X} (x : meq P S) (f : Y ⟶ X) :
  (J.plus_obj P).map f.op (mk x) = mk (x.pullback f) :=
begin
  dsimp [mk, plus_obj],
  simp only [← comp_apply, colimit.ι_pre, ι_colim_map_assoc],
  simp_rw [comp_apply],
  congr' 1,
  apply_fun meq.equiv P _,
  erw equiv.apply_symm_apply,
  ext i,
  simp only [diagram_pullback_app,
    meq.pullback_apply, meq.equiv_apply, ← comp_apply],
  erw [multiequalizer.lift_ι, meq.equiv_symm_eq_apply],
  cases i, refl,
end

lemma to_plus_mk {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : P.obj (op X)) :
  (J.to_plus P).app _ x = mk (meq.mk S x) :=
begin
  dsimp [mk, to_plus],
  let e : S ⟶ ⊤ := hom_of_le (order_top.le_top _),
  rw ← colimit.w _ e.op,
  delta cover.to_multiequalizer,
  simp only [comp_apply],
  congr' 1,
  dsimp [diagram],
  apply concrete.multiequalizer_ext,
  intros i,
  simpa only [← comp_apply, category.assoc, multiequalizer.lift_ι,
    category.comp_id, meq.equiv_symm_eq_apply],
end

lemma to_plus_apply {X : C} {P : Cᵒᵖ ⥤ D} (S : J.cover X) (x : meq P S) (I : S.arrow) :
  (J.to_plus P).app _ (x I) = (J.plus_obj P).map I.f.op (mk x) :=
begin
  dsimp only [to_plus, plus_obj],
  delta cover.to_multiequalizer,
  dsimp [mk],
  simp only [← comp_apply, colimit.ι_pre, ι_colim_map_assoc],
  simp only [comp_apply],
  dsimp only [functor.op],
  let e : (J.pullback I.f).obj (unop (op S)) ⟶ ⊤ := hom_of_le (order_top.le_top _),
  rw ← colimit.w _ e.op,
  simp only [comp_apply],
  congr' 1,
  apply concrete.multiequalizer_ext,
  intros i,
  dsimp [diagram],
  simp only [← comp_apply, category.assoc, multiequalizer.lift_ι,
    category.comp_id, meq.equiv_symm_eq_apply],
  let RR : S.relation :=
    ⟨_, _, _, i.f, 𝟙 _, I.f, i.f ≫ I.f, I.hf, sieve.downward_closed _ I.hf _, by simp⟩,
  cases I,
  erw x.condition RR,
  simpa [RR],
end

lemma to_plus_eq_mk {X : C} {P : Cᵒᵖ ⥤ D} (x : P.obj (op X)) :
  (J.to_plus P).app _ x = mk (meq.mk ⊤ x) :=
begin
  dsimp [mk, to_plus],
  delta cover.to_multiequalizer,
  simp only [comp_apply],
  congr' 1,
  apply_fun (meq.equiv P ⊤),
  ext i,
  simpa,
end

variables [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]

lemma exists_rep {X : C} {P : Cᵒᵖ ⥤ D} (x : (J.plus_obj P).obj (op X)) :
  ∃ (S : J.cover X) (y : meq P S), x = mk y :=
begin
  obtain ⟨S,y,h⟩ := concrete.colimit_exists_rep (J.diagram P X) x,
  use [S.unop, meq.equiv _ _ y],
  rw ← h,
  dsimp [mk],
  simp,
end

lemma eq_mk_iff_exists {X : C} {P : Cᵒᵖ ⥤ D} {S T : J.cover X}
  (x : meq P S) (y : meq P T) : mk x = mk y ↔ (∃ (W : J.cover X) (h1 : W ⟶ S) (h2 : W ⟶ T),
    x.refine h1 = y.refine h2) :=
begin
  split,
  { intros h,
    obtain ⟨W, h1, h2, hh⟩ := concrete.colimit_exists_of_rep_eq _ _ _ h,
    use [W.unop, h1.unop, h2.unop],
    ext I,
    apply_fun (multiequalizer.ι (W.unop.index P) I) at hh,
    convert hh,
    all_goals
    { dsimp [diagram],
      simp only [← comp_apply, multiequalizer.lift_ι, category.comp_id, meq.equiv_symm_eq_apply],
      cases I, refl } },
  { rintros ⟨S,h1,h2,e⟩,
    apply concrete.colimit_rep_eq_of_exists,
    use [(op S), h1.op, h2.op],
    apply concrete.multiequalizer_ext,
    intros i,
    apply_fun (λ ee, ee i) at e,
    convert e,
    all_goals
    { dsimp [diagram],
      simp only [← comp_apply, multiequalizer.lift_ι, meq.equiv_symm_eq_apply],
      cases i, refl } },
end

/-- `P⁺` is always separated. -/
theorem sep {X : C} (P : Cᵒᵖ ⥤ D) (S : J.cover X) (x y : (J.plus_obj P).obj (op X))
  (h : ∀ (I : S.arrow), (J.plus_obj P).map I.f.op x = (J.plus_obj P).map I.f.op y) :
  x = y :=
begin
  -- First, we choose representatives for x and y.
  obtain ⟨Sx,x,rfl⟩ := exists_rep x,
  obtain ⟨Sy,y,rfl⟩ := exists_rep y,
  simp only [res_mk_eq_mk_pullback] at h,

  -- Next, using our assumption,
  -- choose covers over which the pullbacks of these representatives become equal.
  choose W h1 h2 hh using λ (I : S.arrow), (eq_mk_iff_exists _ _).mp (h I),

  -- To prove equality, it suffices to prove that there exists a cover over which
  -- the representatives become equal.
  rw eq_mk_iff_exists,

  -- Construct the cover over which the representatives become equal by combining the various
  -- covers chosen above.
  let B : J.cover X := S.bind W,
  use B,

  -- Prove that this cover refines the two covers over which our representatives are defined
  -- and use these proofs.
  let ex : B ⟶ Sx := hom_of_le begin
    rintros Y f ⟨Z,e1,e2,he2,he1,hee⟩,
    rw ← hee,
    apply le_of_hom (h1 ⟨_, _, he2⟩),
    exact he1,
  end,
  let ey : B ⟶ Sy := hom_of_le begin
    rintros Y f ⟨Z,e1,e2,he2,he1,hee⟩,
    rw ← hee,
    apply le_of_hom (h2 ⟨_, _, he2⟩),
    exact he1,
  end,
  use [ex, ey],

  -- Now prove that indeed the representatives become equal over `B`.
  -- This will follow by using the fact that our representatives become
  -- equal over the chosen covers.
  ext1 I,
  let IS : S.arrow := I.from_middle,
  specialize hh IS,
  let IW : (W IS).arrow := I.to_middle,
  apply_fun (λ e, e IW) at hh,
  convert hh,
  { let Rx : Sx.relation := ⟨I.Y, I.Y, I.Y, 𝟙 _, 𝟙 _, I.f,
      I.to_middle_hom ≫ I.from_middle_hom, _, _, by simp [I.middle_spec]⟩,
    have := x.condition Rx,
    simpa using this },
  { let Ry : Sy.relation := ⟨I.Y, I.Y, I.Y, 𝟙 _, 𝟙 _, I.f,
      I.to_middle_hom ≫ I.from_middle_hom, _, _, by simp [I.middle_spec]⟩,
    have := y.condition Ry,
    simpa using this },
end

lemma inj_of_sep (P : Cᵒᵖ ⥤ D) (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
  (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y) (X : C) :
  function.injective ((J.to_plus P).app (op X)) :=
begin
  intros x y h,
  simp only [to_plus_eq_mk] at h,
  rw eq_mk_iff_exists at h,
  obtain ⟨W, h1, h2, hh⟩ := h,
  apply hsep X W,
  intros I,
  apply_fun (λ e, e I) at hh,
  exact hh
end

/-- An auxiliary definition to be used in the proof of `exists_of_sep` below.
  Given a compatible family of local sections for `P⁺`, and representatives of said sections,
  construct a compatible family of local sections of `P` over the combination of the covers
  associated to the representatives.
  The separatedness condition is used to prove compatibility among these local sections of `P`. -/
def meq_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y)
  (X : C) (S : J.cover X)
  (s : meq (J.plus_obj P) S)
  (T : Π (I : S.arrow), J.cover I.Y)
  (t : Π (I : S.arrow), meq P (T I))
  (ht : ∀ (I : S.arrow), s I = mk (t I)) : meq P (S.bind T) :=
{ val := λ I, t I.from_middle I.to_middle,
  property := begin
    intros II,
    apply inj_of_sep P hsep,
    rw [← comp_apply, ← comp_apply, (J.to_plus P).naturality, (J.to_plus P).naturality,
      comp_apply, comp_apply],
    erw [to_plus_apply (T II.fst.from_middle) (t II.fst.from_middle) II.fst.to_middle,
         to_plus_apply (T II.snd.from_middle) (t II.snd.from_middle) II.snd.to_middle,
         ← ht, ← ht, ← comp_apply, ← comp_apply, ← (J.plus_obj P).map_comp,
         ← (J.plus_obj P).map_comp],
    rw [← op_comp, ← op_comp],
    let IR : S.relation :=
      ⟨_, _, _, II.g₁ ≫ II.fst.to_middle_hom, II.g₂ ≫ II.snd.to_middle_hom,
        II.fst.from_middle_hom, II.snd.from_middle_hom, II.fst.from_middle_condition,
        II.snd.from_middle_condition, _⟩,
    swap, { simp only [category.assoc, II.fst.middle_spec, II.snd.middle_spec], apply II.w },
    exact s.condition IR,
  end }

theorem exists_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y)
  (X : C) (S : J.cover X)
  (s : meq (J.plus_obj P) S) :
  ∃ t : (J.plus_obj P).obj (op X), meq.mk S t = s :=
begin
  have inj : ∀ (X : C), function.injective ((J.to_plus P).app (op X)) := inj_of_sep _ hsep,

  -- Choose representatives for the given local sections.
  choose T t ht using λ I, exists_rep (s I),

  -- Construct a large cover over which we will define a representative that will
  -- provide the gluing of the given local sections.
  let B : J.cover X := S.bind T,
  choose Z e1 e2 he2 he1 hee using λ I : B.arrow, I.hf,

  -- Construct a compatible system of local sections over this large cover, using the chosen
  -- representatives of our local sections.
  -- The compatilibity here follows from the separatedness assumption.
  let w : meq P B := meq_of_sep P hsep X S s T t ht,

  -- The associated gluing will be the candidate section.
  use mk w,
  ext I,
  erw [ht, res_mk_eq_mk_pullback],

  -- Use the separatedness of `P⁺` to prove that this is indeed a gluing of our
  -- original local sections.
  apply sep P (T I),
  intros II,
  simp only [res_mk_eq_mk_pullback, eq_mk_iff_exists],

  -- It suffices to prove equality for representatives over a
  -- convenient sufficiently large cover...
  use (J.pullback II.f).obj (T I),
  let e0 : (J.pullback II.f).obj (T I) ⟶ (J.pullback II.f).obj ((J.pullback I.f).obj B) :=
    hom_of_le begin
      intros Y f hf,
      apply sieve.le_pullback_bind _ _ _ I.hf,
      { cases I,
        exact hf },
    end,
  use [e0, 𝟙 _],
  ext IV,
  dsimp only [meq.refine_apply, meq.pullback_apply, w],
  let IA : B.arrow := ⟨_, (IV.f ≫ II.f) ≫ I.f, _⟩,
  swap,
  { refine ⟨I.Y, _, _, I.hf, _, rfl⟩,
    apply sieve.downward_closed,
    convert II.hf,
    cases I, refl },
  let IB : S.arrow := IA.from_middle,
  let IC : (T IB).arrow := IA.to_middle,
  let ID : (T I).arrow := ⟨IV.Y, IV.f ≫ II.f, sieve.downward_closed (T I) II.hf IV.f⟩,
  change t IB IC = t I ID,
  apply inj IV.Y,
  erw [to_plus_apply (T I) (t I) ID, to_plus_apply (T IB) (t IB) IC, ← ht, ← ht],

  -- Conclude by constructing the relation showing equality...
  let IR : S.relation := ⟨_, _, IV.Y, IC.f, ID.f, IB.f, I.f, _, I.hf, IA.middle_spec⟩,
  convert s.condition IR,
  cases I, refl,
end

variable [reflects_isomorphisms (forget D)]

/-- If `P` is separated, then `P⁺` is a sheaf. -/
theorem is_sheaf_of_sep (P : Cᵒᵖ ⥤ D)
  (hsep : ∀ (X : C) (S : J.cover X) (x y : P.obj (op X)),
    (∀ I : S.arrow, P.map I.f.op x = P.map I.f.op y) → x = y) :
  presheaf.is_sheaf J (J.plus_obj P) :=
begin
  rw presheaf.is_sheaf_iff_multiequalizer,
  intros X S,
  apply is_iso_of_reflects_iso _ (forget D),
  rw is_iso_iff_bijective,
  split,
  { intros x y h,
    apply sep P S _ _,
    intros I,
    apply_fun (meq.equiv _ _) at h,
    apply_fun (λ e, e I) at h,
    convert h,
    { erw [meq.equiv_apply, ← comp_apply, multiequalizer.lift_ι] },
    { erw [meq.equiv_apply, ← comp_apply, multiequalizer.lift_ι] } },
  { rintros (x : (multiequalizer (S.index _) : D)),
    obtain ⟨t,ht⟩ := exists_of_sep P hsep X S (meq.equiv _ _ x),
    use t,
    apply_fun meq.equiv _ _,
    swap, { apply_instance },
    rw ← ht,
    ext i,
    dsimp,
    rw [← comp_apply, multiequalizer.lift_ι],
    refl }
end

variable (J)

/-- `P⁺⁺` is always a sheaf. -/
theorem is_sheaf_plus_plus (P : Cᵒᵖ ⥤ D) :
  presheaf.is_sheaf J (J.plus_obj (J.plus_obj P)) :=
begin
  apply is_sheaf_of_sep,
  intros X S x y,
  apply sep,
end

end plus

variables (J)
variables
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]

/-- The sheafification of a presheaf `P`.
*NOTE:* Additional hypotheses are needed to obtain a proof that this is a sheaf! -/
def sheafify (P : Cᵒᵖ ⥤ D) : Cᵒᵖ ⥤ D := J.plus_obj (J.plus_obj P)

/-- The canonical map from `P` to its sheafification. -/
def to_sheafify (P : Cᵒᵖ ⥤ D) : P ⟶ J.sheafify P :=
J.to_plus P ≫ J.plus_map (J.to_plus P)

/-- The canonical map on sheafifications induced by a morphism. -/
def sheafify_map {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) : J.sheafify P ⟶ J.sheafify Q :=
J.plus_map $ J.plus_map η

@[simp]
lemma sheafify_map_id (P : Cᵒᵖ ⥤ D) : J.sheafify_map (𝟙 P) = 𝟙 (J.sheafify P) :=
by { dsimp [sheafify_map, sheafify], simp }

@[simp]
lemma sheafify_map_comp {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R) :
  J.sheafify_map (η ≫ γ) = J.sheafify_map η ≫ J.sheafify_map γ :=
by { dsimp [sheafify_map, sheafify], simp }

@[simp, reassoc]
lemma to_sheafify_naturality {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) :
  η ≫ J.to_sheafify _ = J.to_sheafify _ ≫ J.sheafify_map η :=
by { dsimp [sheafify_map, sheafify, to_sheafify], simp }

variable (D)

/-- The sheafification of a presheaf `P`, as a functor.
*NOTE:* Additional hypotheses are needed to obtain a proof that this is a sheaf! -/
def sheafification : (Cᵒᵖ ⥤ D) ⥤ Cᵒᵖ ⥤ D := (J.plus_functor D ⋙ J.plus_functor D)

@[simp]
lemma sheafification_obj (P : Cᵒᵖ ⥤ D) : (J.sheafification D).obj P = J.sheafify P := rfl

@[simp]
lemma sheafification_map {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) : (J.sheafification D).map η =
  J.sheafify_map η := rfl

/-- The canonical map from `P` to its sheafification, as a natural transformation.
*Note:* We only show this is a sheaf under additional hypotheses on `D`. -/
def to_sheafification : 𝟭 _ ⟶ sheafification J D :=
J.to_plus_nat_trans D ≫ whisker_right (J.to_plus_nat_trans D) (J.plus_functor D)

@[simp]
lemma to_sheafification_app (P : Cᵒᵖ ⥤ D) : (J.to_sheafification D).app P = J.to_sheafify P := rfl

variable {D}

lemma is_iso_to_sheafify {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  is_iso (J.to_sheafify P) :=
begin
  dsimp [to_sheafify],
  haveI : is_iso (J.to_plus P) := by { apply is_iso_to_plus_of_is_sheaf J P hP },
  haveI : is_iso ((J.plus_functor D).map (J.to_plus P)) := by { apply functor.map_is_iso },
  exact @is_iso.comp_is_iso _ _ _ _ _ (J.to_plus P)
    ((J.plus_functor D).map (J.to_plus P)) _ _,
end

/-- If `P` is a sheaf, then `P` is isomorphic to `J.sheafify P`. -/
def iso_sheafify {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  P ≅ J.sheafify P :=
by letI := is_iso_to_sheafify J hP; exactI as_iso (J.to_sheafify P)

@[simp]
lemma iso_sheafify_hom {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  (J.iso_sheafify hP).hom = J.to_sheafify P := rfl

/-- Given a sheaf `Q` and a morphism `P ⟶ Q`, construct a morphism from
`J.sheafifcation P` to `Q`. -/
def sheafify_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.sheafify P ⟶ Q := J.plus_lift (J.plus_lift η hQ) hQ

@[simp, reassoc]
lemma to_sheafify_sheafify_lift {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q) :
  J.to_sheafify P ≫ sheafify_lift J η hQ = η :=
by { dsimp only [sheafify_lift, to_sheafify], simp }

lemma sheafify_lift_unique {P Q : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (γ : J.sheafify P ⟶ Q) :
  J.to_sheafify P ≫ γ = η → γ = sheafify_lift J η hQ :=
begin
  intros h,
  apply plus_lift_unique,
  apply plus_lift_unique,
  rw [← category.assoc, ← plus_map_to_plus],
  exact h,
end

@[simp]
lemma iso_sheafify_inv {P : Cᵒᵖ ⥤ D} (hP : presheaf.is_sheaf J P) :
  (J.iso_sheafify hP).inv = J.sheafify_lift (𝟙 _) hP :=
begin
  apply J.sheafify_lift_unique,
  simp [iso.comp_inv_eq],
end

lemma sheafify_hom_ext {P Q : Cᵒᵖ ⥤ D} (η γ : J.sheafify P ⟶ Q) (hQ : presheaf.is_sheaf J Q)
  (h : J.to_sheafify P ≫ η = J.to_sheafify P ≫ γ) : η = γ :=
begin
  apply J.plus_hom_ext _ _ hQ,
  apply J.plus_hom_ext _ _ hQ,
  rw [← category.assoc, ← category.assoc, ← plus_map_to_plus],
  exact h,
end

@[simp, reassoc]
lemma sheafify_map_sheafify_lift {P Q R : Cᵒᵖ ⥤ D} (η : P ⟶ Q) (γ : Q ⟶ R)
  (hR : presheaf.is_sheaf J R) :
  J.sheafify_map η ≫ J.sheafify_lift γ hR = J.sheafify_lift (η ≫ γ) hR :=
begin
  apply J.sheafify_lift_unique,
  rw [← category.assoc, ← J.to_sheafify_naturality,
    category.assoc, to_sheafify_sheafify_lift],
end

end grothendieck_topology

variables (J)
variables
  [concrete_category.{max v u} D]
  [preserves_limits (forget D)]
  [∀ (P : Cᵒᵖ ⥤ D) (X : C) (S : J.cover X), has_multiequalizer (S.index P)]
  [∀ (X : C), has_colimits_of_shape (J.cover X)ᵒᵖ D]
  [∀ (X : C), preserves_colimits_of_shape (J.cover X)ᵒᵖ (forget D)]
  [reflects_isomorphisms (forget D)]

lemma grothendieck_topology.sheafify_is_sheaf (P : Cᵒᵖ ⥤ D) :
  presheaf.is_sheaf J (J.sheafify P) :=
grothendieck_topology.plus.is_sheaf_plus_plus _ _

variables (D)

/-- The sheafification functor, as a functor taking values in `Sheaf`. -/
@[simps]
def presheaf_to_Sheaf : (Cᵒᵖ ⥤ D) ⥤ Sheaf J D :=
{ obj := λ P, ⟨J.sheafify P, J.sheafify_is_sheaf P⟩,
  map := λ P Q η, ⟨J.sheafify_map η⟩,
  map_id' := λ P, Sheaf.hom.ext _ _ $ J.sheafify_map_id _,
  map_comp' := λ P Q R f g, Sheaf.hom.ext _ _ $ J.sheafify_map_comp _ _ }

instance presheaf_to_Sheaf_preserves_zero_morphisms [preadditive D] :
  (presheaf_to_Sheaf J D).preserves_zero_morphisms  :=
{ map_zero' := λ F G, by { ext, erw [colimit.ι_map, comp_zero, J.plus_map_zero,
    J.diagram_nat_trans_zero, zero_comp] } }

/-- The sheafification functor is left adjoint to the forgetful functor. -/
@[simps unit_app counit_app_val]
def sheafification_adjunction : presheaf_to_Sheaf J D ⊣ Sheaf_to_presheaf J D :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ P Q,
  { to_fun := λ e, J.to_sheafify P ≫ e.val,
    inv_fun := λ e, ⟨J.sheafify_lift e Q.2⟩,
    left_inv := λ e, Sheaf.hom.ext _ _ $ (J.sheafify_lift_unique _ _ _ rfl).symm,
    right_inv := λ e, J.to_sheafify_sheafify_lift _ _ },
  hom_equiv_naturality_left_symm' := begin
    intros P Q R η γ, ext1, dsimp, symmetry,
    apply J.sheafify_map_sheafify_lift,
  end,
  hom_equiv_naturality_right' := λ P Q R η γ, by { dsimp, rw category.assoc } }

instance Sheaf_to_presheaf_is_right_adjoint : is_right_adjoint (Sheaf_to_presheaf J D) :=
⟨_, sheafification_adjunction J D⟩

instance presheaf_mono_of_mono {F G : Sheaf J D} (f : F ⟶ G) [mono f] : mono f.1 :=
(Sheaf_to_presheaf J D).map_mono _

lemma Sheaf.hom.mono_iff_presheaf_mono {F G : Sheaf J D} (f : F ⟶ G) : mono f ↔ mono f.1 :=
⟨λ m, by { resetI, apply_instance },
 λ m, by { resetI, exact Sheaf.hom.mono_of_presheaf_mono J D f }⟩

variables {J D}
/-- A sheaf `P` is isomorphic to its own sheafification. -/
@[simps]
def sheafification_iso (P : Sheaf J D) :
  P ≅ (presheaf_to_Sheaf J D).obj P.val :=
{ hom := ⟨(J.iso_sheafify P.2).hom⟩,
  inv := ⟨(J.iso_sheafify P.2).inv⟩,
  hom_inv_id' := by { ext1, apply (J.iso_sheafify P.2).hom_inv_id },
  inv_hom_id' := by { ext1, apply (J.iso_sheafify P.2).inv_hom_id } }

instance is_iso_sheafification_adjunction_counit (P : Sheaf J D) :
  is_iso ((sheafification_adjunction J D).counit.app P) :=
is_iso_of_fully_faithful (Sheaf_to_presheaf J D) _

instance sheafification_reflective : is_iso (sheafification_adjunction J D).counit :=
nat_iso.is_iso_of_is_iso_app _

end category_theory


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

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

/-!
# Documentation commands

We generate html documentation from mathlib. It is convenient to collect lists of tactics, commands,
notes, etc. To facilitate this, we declare these documentation entries in the library
using special commands.

* `library_note` adds a note describing a certain feature or design decision. These can be
  referenced in doc strings with the text `note [name of note]`.
* `add_tactic_doc` adds an entry documenting an interactive tactic, command, hole command, or
  attribute.

Since these commands are used in files imported by `tactic.core`, this file has no imports.

## Implementation details

`library_note note_id note_msg` creates a declaration `` `library_note.i `` for some `i`.
This declaration is a pair of strings `note_id` and `note_msg`, and it gets tagged with the
`library_note` attribute.

Similarly, `add_tactic_doc` creates a declaration `` `tactic_doc.i `` that stores the provided
information.
-/

/- warning: string.hash -> String.hash is a dubious translation:
lean 3 declaration is
  String -> Nat
but is expected to have type
  ([mdata borrowed:1 String]) -> UInt64
Case conversion may be inaccurate. Consider using '#align string.hash String.hashₓ'. -/
/-- A rudimentary hash function on strings. -/
def String.hash (s : String) : ℕ :=
  s.fold 1 fun h c => (33 * h + c.val) % unsignedSz
#align string.hash String.hash

/-- Get the last component of a name, and convert it to a string. -/
unsafe def name.last : Name → String
  | Name.mk_string s _ => s
  | Name.mk_numeral n _ => repr n
  | anonymous => "[anonymous]"
#align name.last name.last

open Tactic

/-- `copy_doc_string fr to` copies the docstring from the declaration named `fr`
to each declaration named in the list `to`. -/
unsafe def tactic.copy_doc_string (fr : Name) (to : List Name) : tactic Unit := do
  let fr_ds ← doc_string fr
  to fun tgt => add_doc_string tgt fr_ds
#align tactic.copy_doc_string tactic.copy_doc_string

open Lean Lean.Parser Interactive

/-- `copy_doc_string source → target_1 target_2 ... target_n` copies the doc string of the
declaration named `source` to each of `target_1`, `target_2`, ..., `target_n`.
 -/
@[user_command]
unsafe def copy_doc_string_cmd (_ : parse (tk "copy_doc_string")) : parser Unit := do
  let fr ← parser.ident
  tk "->"
  let to ← parser.many parser.ident
  let expr.const fr _ ← resolve_name fr
  let to ← parser.of_tactic (to.mapM fun n => expr.const_name <$> resolve_name n)
  tactic.copy_doc_string fr to
#align copy_doc_string_cmd copy_doc_string_cmd

/-! ### The `library_note` command -/

/-- A user attribute `library_note` for tagging decls of type `string × string` for use in note
output. -/
@[user_attribute]
unsafe def library_note_attr : user_attribute
    where
  Name := `library_note
  descr := "Notes about library features to be included in documentation"
  parser := failed
#align library_note_attr library_note_attr

/-- `mk_reflected_definition name val` constructs a definition declaration by reflection.

Example: ``mk_reflected_definition `foo 17`` constructs the definition
declaration corresponding to `def foo : ℕ := 17`
-/
unsafe def mk_reflected_definition (decl_name : Name) {type} [reflected _ type] (body : type)
    [reflected _ body] : declaration :=
  mk_definition decl_name (reflect type).collect_univ_params (reflect type) (reflect body)
#align mk_reflected_definition mk_reflected_definition

/--
If `note_name` and `note` are strings, `add_library_note note_name note` adds a declaration named
`library_note.<note_name>` with `note` as the docstring and tags it with the `library_note`
attribute.
-/
unsafe def tactic.add_library_note (note_name note : String) : tactic Unit := do
  let decl_name := .str `library_note note_name
  add_decl <| mk_reflected_definition decl_name ()
  add_doc_string decl_name note
  library_note_attr decl_name () tt none
#align tactic.add_library_note tactic.add_library_note

open Tactic

/-- A command to add library notes. Syntax:
```
/--
note message
-/
library_note "note id"
```
-/
@[user_command]
unsafe def library_note (mi : interactive.decl_meta_info) (_ : parse (tk "library_note")) :
    parser Unit := do
  let note_name ← parser.pexpr
  let note_name ← eval_pexpr String note_name
  let some doc_string ← pure mi.doc_string |
    fail "library_note requires a doc string"
  add_library_note note_name doc_string
#align library_note library_note

/-- Collects all notes in the current environment.
Returns a list of pairs `(note_id, note_content)` -/
unsafe def tactic.get_library_notes : tactic (List (String × String)) :=
  attribute.get_instances `library_note >>=
    List.mapM fun dcl => Prod.mk dcl.getLast <$> doc_string dcl
#align tactic.get_library_notes tactic.get_library_notes

/-! ### The `add_tactic_doc_entry` command -/

/-- The categories of tactic doc entry. -/
inductive DocCategory
  | tactic
  | cmd
  | hole_cmd
  | attr
  deriving DecidableEq, has_reflect
#align doc_category DocCategory

/-- Format a `doc_category` -/
unsafe def doc_category.to_string : DocCategory → String
  | DocCategory.tactic => "tactic"
  | DocCategory.cmd => "command"
  | DocCategory.hole_cmd => "hole_command"
  | DocCategory.attr => "attribute"
#align doc_category.to_string doc_category.to_string

unsafe instance : has_to_format DocCategory :=
  ⟨↑doc_category.to_string⟩

/-- The information used to generate a tactic doc entry -/
structure TacticDocEntry where
  Name : String
  category : DocCategory
  declNames : List Name
  tags : List String := []
  inheritDescriptionFrom : Option Name := none
  deriving has_reflect
#align tactic_doc_entry TacticDocEntry

/-- Turns a `tactic_doc_entry` into a JSON representation. -/
unsafe def tactic_doc_entry.to_json (d : TacticDocEntry) (desc : String) : json :=
  json.object
    [("name", d.Name), ("category", d.category.toString),
      ("decl_names", d.declNames.map (json.of_string ∘ toString)),
      ("tags", d.tags.map json.of_string), ("description", desc)]
#align tactic_doc_entry.to_json tactic_doc_entry.to_json

unsafe instance tactic_doc_entry.has_to_string : ToString (TacticDocEntry × String) :=
  ⟨fun ⟨doc, desc⟩ => json.unparse (doc.to_json desc)⟩
#align tactic_doc_entry.has_to_string tactic_doc_entry.has_to_string

/-- A user attribute `tactic_doc` for tagging decls of type `tactic_doc_entry`
for use in doc output -/
@[user_attribute]
unsafe def tactic_doc_entry_attr : user_attribute
    where
  Name := `tactic_doc
  descr := "Information about a tactic to be included in documentation"
  parser := failed
#align tactic_doc_entry_attr tactic_doc_entry_attr

/-- Collects everything in the environment tagged with the attribute `tactic_doc`. -/
unsafe def tactic.get_tactic_doc_entries : tactic (List (TacticDocEntry × String)) :=
  attribute.get_instances `tactic_doc >>=
    List.mapM fun dcl => Prod.mk <$> (mk_const dcl >>= eval_expr TacticDocEntry) <*> doc_string dcl
#align tactic.get_tactic_doc_entries tactic.get_tactic_doc_entries

/-- `add_tactic_doc tde` adds a declaration to the environment
with `tde` as its body and tags it with the `tactic_doc`
attribute. If `tde.decl_names` has exactly one entry `` `decl`` and
if `tde.description` is the empty string, `add_tactic_doc` uses the doc
string of `decl` as the description. -/
unsafe def tactic.add_tactic_doc (tde : TacticDocEntry) (doc : Option String) : tactic Unit := do
  let desc ←
    doc <|> do
        let inh_id ←
          match tde.inheritDescriptionFrom, tde.declNames with
            | some inh_id, _ => pure inh_id
            | none, [inh_id] => pure inh_id
            | none, _ =>
              fail
                "A tactic doc entry must either:\n 1. have a description written as a doc-string for the `add_tactic_doc` invocation, or\n 2. have a single declaration in the `decl_names` field, to inherit a description from, or\n 3. explicitly indicate the declaration to inherit the description from using\n    `inherit_description_from`."
        doc_string inh_id <|> fail (toString inh_id ++ " has no doc string")
  let decl_name := .str (.str `tactic_doc tde.category.toString) tde.Name
  add_decl <| mk_definition decl_name [] q(TacticDocEntry) (reflect tde)
  add_doc_string decl_name desc
  tactic_doc_entry_attr decl_name () tt none
#align tactic.add_tactic_doc tactic.add_tactic_doc

/-- A command used to add documentation for a tactic, command, hole command, or attribute.

Usage: after defining an interactive tactic, command, or attribute,
add its documentation as follows.
```lean
/--
describe what the command does here
-/
add_tactic_doc
{ name := "display name of the tactic",
  category := cat,
  decl_names := [`dcl_1, `dcl_2],
  tags := ["tag_1", "tag_2"] }
```

The argument to `add_tactic_doc` is a structure of type `tactic_doc_entry`.
* `name` refers to the display name of the tactic; it is used as the header of the doc entry.
* `cat` refers to the category of doc entry.
  Options: `doc_category.tactic`, `doc_category.cmd`, `doc_category.hole_cmd`, `doc_category.attr`
* `decl_names` is a list of the declarations associated with this doc. For instance,
  the entry for `linarith` would set ``decl_names := [`tactic.interactive.linarith]``.
  Some entries may cover multiple declarations.
  It is only necessary to list the interactive versions of tactics.
* `tags` is an optional list of strings used to categorize entries.
* The doc string is the body of the entry. It can be formatted with markdown.
  What you are reading now is the description of `add_tactic_doc`.

If only one related declaration is listed in `decl_names` and if this
invocation of `add_tactic_doc` does not have a doc string, the doc string of
that declaration will become the body of the tactic doc entry. If there are
multiple declarations, you can select the one to be used by passing a name to
the `inherit_description_from` field.

If you prefer a tactic to have a doc string that is different then the doc entry,
you should write the doc entry as a doc string for the `add_tactic_doc` invocation.

Note that providing a badly formed `tactic_doc_entry` to the command can result in strange error
messages.

-/
@[user_command]
unsafe def add_tactic_doc_command (mi : interactive.decl_meta_info)
    (_ : parse <| tk "add_tactic_doc") : parser Unit := do
  let pe ← parser.pexpr
  let e ← eval_pexpr TacticDocEntry pe
  tactic.add_tactic_doc e mi
#align add_tactic_doc_command add_tactic_doc_command

/-- At various places in mathlib, we leave implementation notes that are referenced from many other
files. To keep track of these notes, we use the command `library_note`. This makes it easy to
retrieve a list of all notes, e.g. for documentation output.

These notes can be referenced in mathlib with the syntax `Note [note id]`.
Often, these references will be made in code comments (`--`) that won't be displayed in docs.
If such a reference is made in a doc string or module doc, it will be linked to the corresponding
note in the doc display.

Syntax:
```
/--
note message
-/
library_note "note id"
```

An example from `meta.expr`:

```
/--
Some declarations work with open expressions, i.e. an expr that has free variables.
Terms will free variables are not well-typed, and one should not use them in tactics like
`infer_type` or `unify`. You can still do syntactic analysis/manipulation on them.
The reason for working with open types is for performance: instantiating variables requires
iterating through the expression. In one performance test `pi_binders` was more than 6x
quicker than `mk_local_pis` (when applied to the type of all imported declarations 100x).
-/
library_note "open expressions"
```

This note can be referenced near a usage of `pi_binders`:

```
-- See Note [open expressions]
/-- behavior of f -/
def f := pi_binders ...
```
-/
add_tactic_doc
  { Name := "library_note"
    category := DocCategory.cmd
    declNames := [`library_note, `tactic.add_library_note]
    tags := ["documentation"]
    inheritDescriptionFrom := `library_note }

add_tactic_doc
  { Name := "add_tactic_doc"
    category := DocCategory.cmd
    declNames := [`add_tactic_doc_command, `tactic.add_tactic_doc]
    tags := ["documentation"]
    inheritDescriptionFrom := `add_tactic_doc_command }

add_tactic_doc
  { Name := "copy_doc_string"
    category := DocCategory.cmd
    declNames := [`copy_doc_string_cmd, `tactic.copy_doc_string]
    tags := ["documentation"]
    inheritDescriptionFrom := `copy_doc_string_cmd }

-- add docs to core tactics
/-- The congruence closure tactic `cc` tries to solve the goal by chaining
equalities from context and applying congruence (i.e. if `a = b`, then `f a = f b`).
It is a finishing tactic, i.e. it is meant to close
the current goal, not to make some inconclusive progress.
A mostly trivial example would be:

```lean
example (a b c : ℕ) (f : ℕ → ℕ) (h: a = b) (h' : b = c) : f a = f c := by cc
```

As an example requiring some thinking to do by hand, consider:

```lean
example (f : ℕ → ℕ) (x : ℕ)
  (H1 : f (f (f x)) = x) (H2 : f (f (f (f (f x)))) = x) :
  f x = x :=
by cc
```

The tactic works by building an equality matching graph. It's a graph where
the vertices are terms and they are linked by edges if they are known to
be equal. Once you've added all the equalities in your context, you take
the transitive closure of the graph and, for each connected component
(i.e. equivalence class) you can elect a term that will represent the
whole class and store proofs that the other elements are equal to it.
You then take the transitive closure of these equalities under the
congruence lemmas.

The `cc` implementation in Lean does a few more tricks: for example it
derives `a=b` from `nat.succ a = nat.succ b`, and `nat.succ a !=
nat.zero` for any `a`.

* The starting reference point is Nelson, Oppen, [Fast decision procedures based on congruence
closure](http://www.cs.colorado.edu/~bec/courses/csci5535-s09/reading/nelson-oppen-congruence.pdf),
Journal of the ACM (1980)

* The congruence lemmas for dependent type theory as used in Lean are described in
[Congruence closure in intensional type theory](https://leanprover.github.io/papers/congr.pdf)
(de Moura, Selsam IJCAR 2016).
-/
add_tactic_doc
  { Name := "cc (congruence closure)"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.cc]
    tags := ["core", "finishing"] }

/-- `conv {...}` allows the user to perform targeted rewriting on a goal or hypothesis,
by focusing on particular subexpressions.

See <https://leanprover-community.github.io/extras/conv.html> for more details.

Inside `conv` blocks, mathlib currently additionally provides
* `erw`,
* `ring`, `ring2` and `ring_exp`,
* `norm_num`,
* `norm_cast`,
* `apply_congr`, and
* `conv` (within another `conv`).

`apply_congr` applies congruence lemmas to step further inside expressions,
and sometimes gives better results than the automatically generated
congruence lemmas used by `congr`.

Using `conv` inside a `conv` block allows the user to return to the previous
state of the outer `conv` block after it is finished. Thus you can continue
editing an expression without having to start a new `conv` block and re-scoping
everything. For example:
```lean
example (a b c d : ℕ) (h₁ : b = c) (h₂ : a + c = a + d) : a + b = a + d :=
by conv
{ to_lhs,
  conv
  { congr, skip,
    rw h₁ },
  rw h₂, }
```
Without `conv`, the above example would need to be proved using two successive
`conv` blocks, each beginning with `to_lhs`.

Also, as a shorthand, `conv_lhs` and `conv_rhs` are provided, so that
```lean
example : 0 + 0 = 0 :=
begin
  conv_lhs { simp }
end
```
just means
```lean
example : 0 + 0 = 0 :=
begin
  conv { to_lhs, simp }
end
```
and likewise for `to_rhs`.
-/
add_tactic_doc
  { Name := "conv"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.conv]
    tags := ["core"] }

add_tactic_doc
  { Name := "simp"
    category := DocCategory.tactic
    declNames := [`tactic.interactive.simp]
    tags := ["core", "simplification"] }

/-- Accepts terms with the type `component tactic_state string` or `html empty` and
renders them interactively.
Requires a compatible version of the vscode extension to view the resulting widget.

### Example:

```lean
/-- A simple counter that can be incremented or decremented with some buttons. -/
meta def counter_widget {π α : Type} : component π α :=
component.ignore_props $ component.mk_simple int int 0 (λ _ x y, (x + y, none)) (λ _ s,
  h "div" [] [
    button "+" (1 : int),
    html.of_string $ to_string $ s,
    button "-" (-1)
  ]
)

#html counter_widget
```
-/
add_tactic_doc
  { Name := "#html"
    category := DocCategory.cmd
    declNames := [`show_widget_cmd]
    tags := ["core", "widgets"] }

/-- The `add_decl_doc` command is used to add a doc string to an existing declaration.

```lean
def foo := 5

/--
Doc string for foo.
-/
add_decl_doc foo
```
-/
@[user_command]
unsafe def add_decl_doc_command (mi : interactive.decl_meta_info) (_ : parse <| tk "add_decl_doc") :
    parser Unit := do
  let n ← parser.ident
  let n ← resolve_constant n
  let some doc ← pure mi.doc_string |
    fail "add_decl_doc requires a doc string"
  add_doc_string n doc
#align add_decl_doc_command add_decl_doc_command

add_tactic_doc
  { Name := "add_decl_doc"
    category := DocCategory.cmd
    declNames := [`` add_decl_doc_command]
    tags := ["documentation"] }


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Instances of `traversable` for types from the core library
-/

import category.traversable.basic category.basic category.functor category.applicative
import data.list.basic data.set.lattice

universes u v

open function

instance : traversable id := ⟨λ _ _ _ _, id⟩
instance : is_lawful_traversable id := by refine {..}; intros; refl

section option

open function functor

section inst

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

instance : traversable option := ⟨@option.traverse⟩

end inst

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

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 }

namespace list

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

open applicative functor
open list (cons)

protected lemma id_traverse {α} (xs : list α) :
  list.traverse id.mk xs = xs :=
by induction xs; simp! * with functor_norm; refl

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 : traversable list := ⟨@list.traverse⟩

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

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; exact assume h, match h with end
| []      (b::bs) := by simp
| (a::as) (b::bs) :=
  suffices (b :: bs : list β') ∈ traverse f (a :: as) ↔ b ∈ f a ∧ bs ∈ traverse f as,
    by simpa [mem_traverse as bs],
  iff.intro
    (assume ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩, ⟨hb, hl⟩)
    (assume ⟨hb, hl⟩, ⟨_, ⟨b, hb, rfl⟩, _, hl, rfl⟩)

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 def traverse {α β} (f : α → F β) : σ ⊕ α → F (σ ⊕ β)
| (sum.inl x) := pure (sum.inl x)
| (sum.inr x) := sum.inr <$> f x

variables [is_lawful_applicative F] [is_lawful_applicative G]

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

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.mapr, sum.traverse, id_map] with functor_norm; congr

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.mapr, sum.traverse, id_map] with functor_norm

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} : traversable.{u} (sum σ) := ⟨@sum.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 σ }

end sum


/-
Here is an example where temporary metavariables from typeclass resolution
could spill into nested typeclass resolution, for which the outer TC succeeds
iff:

1. the inner TC is still called, even with the leaked tmp mvars
2. the inner TC is allowed to assign the leaked tmp mvars

This example will *NOT* work in Lean4.

Although it would be easy to allow inner TC to set the outer TC tmp mvars,
the issue is that the solution to the inner TC problem may not be unique,
and it would be extremely difficult to allow backtracking from the outer TC
through to the inner TC.

In Lean4, inner TC can be called with leaked temporary mvars from the outer TC,
but they are treated as opaque, just as regular mvars are treated in the outer TC.
So, this example will fail.
-/

class Foo  (α : Type) : Type := (x : Unit)
class Zoo  (α : Type) : Type := (x : Unit)
class Bar  (α : Type) : Type := (x : Unit)
class HasParam (α : Type) [Bar α] : Type := (x : Unit)

instance FooToBar (α : Type) [f : Foo α] : Bar α :=
match f.x with
| () => {x:=()}

instance ZooToBar (α : Type) [z : Zoo α] : Bar α :=
match z.x with
| () => {x:=()}

instance HasParamInst (α : Type) [h : Foo α] : HasParam α := {x:=()}

class Top : Type := (x : Unit)

instance FooInt : Foo Int := {x:=()}
instance AllZoo (α : Type) : Zoo α := {x:=()}

instance Bad (α : Type) [HasParam α] : Top := Top.mk ()

set_option pp.all true
set_option trace.class_instances true
set_option trace.type_context.complete_instance true

def foo [Top] : Unit := ()
#check @foo _

/-
[class_instances]  class-instance resolution trace
[class_instances] (0) ?x_0 : Top := @Bad ?x_1 ?x_2
[class_instances] (1) ?x_2 : @HasParam ?x_1 (@ZooToBar ?x_1 (AllZoo ?x_1)) := @HasParamInst ?x_3 ?x_4
[type_context.complete_instance] would have synthed: Foo ?x_3
[type_context.complete_instance] would have synthed: Foo ?x_3
failed is_def_eq
-/

def couldWork : Top :=
@Bad Int (@HasParamInst Int FooInt)

#print couldWork
/-
def couldWork : Top :=
@Bad Int (@HasParamInst Int FooInt)
-/


import tactic.find

#find (ff = _)

constants
(f : nat → nat)
(f₀ : f 0 = 0)
(f₁ : f 1 = 1)
(f₂ : f 2 = 1)
(f_next : ∀ n : nat, f (n + 3) = f (n + 2) + f (n + 1) ∨ f (n + 3) = f (n + 1) + f n)

namespace evaluation

meta def hasElement : list nat → nat → bool
| [] _ := ff
| (x :: xs) e := if e = x then tt else hasElement xs e

#eval hasElement [1,2,3] 1 -- tt
#eval hasElement [1,2,3] 4 -- ff

#reduce hasElement [1,2,3] 1 -- tt

-- def union (lx ly : list nat) : list nat :=
-- match lx, ly with
-- | [], listy := listy
-- | listx, [] := listx
-- | (x :: xs), listy := if hasElem listy x then union xs listy else union xs (x :: listy)
-- end
-- @[reducible]
meta def union : list nat → list nat → list nat
| [] ys := ys
| (x :: xs) ys := if hasElement ys x then union xs ys else union xs (x :: ys)

#print union._main

#eval union [1,2,3,4,5] [1] -- [5, 4, 3, 2, 1]
#eval union [1,2,3] [4,5,6] -- [3, 2, 1, 4, 5, 6]

#eval union [1,2,3] [] -- [3, 2, 1]
#reduce union [1,2,3] [] -- [union._main] [2, 3] [1], why reduce doesn't return the same result as eval?

end evaluation

namespace lemmas

set_option trace.simplify.rewrite true

constant hasElement : list nat → nat → bool

namespace hasElement

axiom base (n : nat) : hasElement [] n = ff
axiom step (x : nat) (xs : list nat) : hasElement (x :: xs) x = tt
axiom step_not_eq (x y : nat) (xs : list nat) (h : x ≠ y) :
  hasElement (x :: xs) y = hasElement xs y

lemma empty_not_contains_any (x : nat) : ¬ hasElement [] x = tt :=
begin
  rw hasElement.base _,
  -- change ¬ false = true, -- fail
  -- rw not.elim, -- fail
  -- rw not_false_iff, -- fail
  apply not.intro,
  exact bool.ff_ne_tt,
end

lemma single {x : nat} : hasElement [x] x :=
  hasElement.step x []

lemma two (x y : nat) : hasElement [x, y] y :=
begin
  -- if x = y => tt
  -- if x ≠ y => hasElement [y] y => tt [by single]
  by_cases (x = y),
  {
    rw ←h,
    exact hasElement.step x [x],
  },
  {
    change x ≠ y at h,
    -- rw hasElement.step_not_eq _ _ _ h, -- OK
    rw hasElement.step_not_eq,
    { exact @single y },
    { exact h },
  },
end

example : ¬ hasElement [0] 1 :=
begin
  rw hasElement.step_not_eq,
  apply empty_not_contains_any,
  exact zero_ne_one,
end

#print two

end hasElement

variables {x : ℕ} {xs ys : list ℕ}

constant union : list nat → list nat → list nat

axiom union_base (xs : list nat) :
  union [] xs = xs

axiom union_step₁ (h : hasElement ys x) :
  union (x :: xs) ys = union xs ys

axiom union_step₂ (h : hasElement ys x → false) :
  union (x :: xs) ys = union xs (x :: ys)

lemma union_single : union [x] [x] = [x] :=
begin
  have h₁ :                    union []  [x] = [x]          := union_base [x],
  have h₂ : hasElement [x] x → union [x] [x] = union [] [x] := union_step₁,
  have h₃ :                    union [x] [x] = union [] [x] := h₂ hasElement.single,
  apply eq.trans h₃,
  exact h₁,
end

lemma union_single' : union [x] [x] = [x] :=
begin
  rw union_step₁,
  rw union_base,
  apply hasElement.single,
end

#print notation >>=

open tactic
meta def trace_all : tactic unit :=
   do n ← num_goals
    , trace "num_goals ="
    , trace n
    , trace_state
    , trace "---------------------------------------------"
    , trace_result

lemma union_single'' : union [x] [x] = [x] := by {
  apply eq.trans (union_step₁ hasElement.single),
  trace_all,
  sorry
}

meta def test_tactic : tactic unit :=
do
  define `x (expr.const `nat [])
, trace "-- after assert --"
, trace_state
, n ← get_local `n
, trace (infer_type n)

example (n : nat) : n = n := by { test_tactic, sorry }

example : (1 = 2) → (2 = 3) → (3 = 1) := begin
  assume h1 h2,
  apply eq.symm,
  apply eq.subst h2,
  apply eq.subst h1,
  apply eq.refl,
  trace_result,
  trace_call_stack,
end

example (a : nat) (b : bool) (c : int) : true := by {
  do
    a ← get_local `a
  , b ← get_local `b
  , c ← get_local `c
  , infer_type a >>= trace
  , infer_type b >>= trace
  , infer_type c >>= trace
  , interactive.sorry
}

set_option trace.app_builder true
-- set_option pp.all true

example (a b c : ℕ) : true := by {
  do
    a ← get_local `a
  , x ← mk_app `nat.succ [a] -- x : expr
  , r ← to_expr ```(%%x + b * c + (λ n, n) 100) -- to_expr : pexpr → tactic expr
  , trace r -- a.succ + b * c + (λ (n : ℕ), n) 100
  , infer_type r >>= trace -- ℕ
  , interactive.trivial -- or exact_dec_trivial
}

example (a b c : nat) (H1 : a = b) (H2 : b = c) : a = c :=
by do
  --  refine ```(eq.trans H1 _),
   interactive.refine ```(eq.trans H1 _),
   trace_state,
   assumption

end lemmas

meta def solve (n : nat) (f : nat → nat) :=
match n, f with
| 0, f := 0
| _, _ := 1
end

-- solve n = [f 0, f 1, f 2, ... f (n-1)]
-- solve 0 = [[]]
-- solve 1 = [[0]]
-- solve 2 = [[0], [1]]
-- solve 3 = [[0], [1], [1]]
-- solve 4 = [[0], [1], [1], [1, 2]]
-- solve 5 = [[0], [1], [1], [1, 2], X],
--    where X = (1 + [1, 2]) ∪ (1 + 1) = [2, 3] ∪ [2] = [2, 3]

#print add_lt_add_of_le_of_lt -- a ≤ b → c < d → a + c < b + d

#print add_pos_of_nonneg_of_pos -- 0 ≤ a → 0 < b → 0 < a + b
-- (ha : 0 ≤ a) (hb : 0 < b),
  -- zero_add 0 ▸ add_lt_add_of_le_of_lt ha hb

#print notation ▸ -- eq.subst #1 #0
#print notation + -- has_add.add #1 #0
#print eq.subst