import .love05_inductive_predicates_demo

/- # LoVe Demo 7: Metaprogramming

Users can extend Lean with custom monadic tactics and tools. This kind of
programming—programming the prover—is called metaprogramming.

Lean's metaprogramming framework uses mostly the same notions and syntax as
Lean's input language itself.

Abstract syntax trees __reflect__ internal data structures, e.g., for
expressions (terms).

The prover's C++ internals are exposed through Lean interfaces, which we can
use for accessing the current context and goal, unifying expressions, querying
and modifying the environment, and setting attributes (e.g., `@[simp]`).

Most of Lean's predefined tactics are implemented in Lean (and not in C++).

Example applications:

* proof goal transformations;
* heuristic proof search;
* decision procedures;
* definition generators;
* advisor tools;
* exporters;
* ad hoc automation.

Advantages of Lean's metaprogramming framework:

* Users do not need to learn another programming language to write
  metaprograms; they can work with the same constructs and notation used to
  define ordinary objects in the prover's library.

* Everything in that library is available for metaprogramming purposes.

* Metaprograms can be written and debugged in the same interactive environment,
  encouraging a style where formal libraries and supporting automation are
  developed at the same time. -/

set_option pp.beta true
set_option pp.generalized_field_notation false

namespace LoVe

/- ## Tactics and Tactic Combinators

When programming our own tactics, we often need to repeat some actions on
several goals, or to recover if a tactic fails. Tactic combinators help in such
case.

`repeat` applies its argument repeatedly on all (sub…sub)goals until it cannot
be applied any further. -/

lemma repeat_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat { apply even.add_two },
  repeat { sorry }
end

/- The "orelse" combinator `<|>` tries its first argument and applies its
second argument in case of failure. -/

lemma repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  repeat {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/- `iterate` works repeatedly on the first goal until it fails; then it
stops. -/

lemma iterate_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  iterate {
    apply even.add_two
    <|> apply even.zero },
  repeat { sorry }
end

/- `all_goals` applies its argument exactly once to each goal. It succeeds only
if the argument succeeds on **all** goals. -/

lemma all_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { apply even.add_two },   -- fails
  repeat { sorry }
end

/- `try` transforms its argument into a tactic that never fails. -/

lemma all_goals_try_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  all_goals { try { apply even.add_two } },
  repeat { sorry }
end

/- `any_goals` applies its argument exactly once to each goal. It succeeds
if the argument succeeds on **any** goal. -/

lemma any_goals_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { apply even.add_two },
  repeat { sorry }
end

/- `solve1` transforms its argument into an all-or-nothing tactic. If the
argument does not prove the goal, `solve1` fails. -/

lemma any_goals_solve1_repeat_orelse_example :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  repeat { apply and.intro },
  any_goals { solve1 { repeat {
    apply even.add_two
    <|> apply even.zero } } },
  repeat { sorry }
end

/- The combinators `repeat`, `iterate`, `all_goals`, and `any_goals` can easily
lead to infinite looping: -/

/-
lemma repeat_not_example :
  ¬ even 1 :=
begin
  repeat { apply not.intro },
  sorry
end
-/

/- Let us start with the actual metaprogramming, by coding a custom tactic. The
tactic embodies the behavior we hardcoded in the `solve1` example above: -/

meta def intro_and_even : tactic unit :=
do
  tactic.repeat (tactic.applyc ``and.intro),
  tactic.any_goals (tactic.solve1 (tactic.repeat
    (tactic.applyc ``even.add_two
     <|> tactic.applyc ``even.zero))),
  pure ()

/- The `meta` keyword makes it possible for the function to call other
metafunctions. The `do` keyword enters a monad, and the `<|>` operator is the
"orelse" operator of alternative monads. At the end, we return `()`, of type
`unit`, to ensure the metaprogram has the desired type.

Any executable Lean definition can be used as a metaprogram. In addition, we can
put `meta` in front of a definition to indicate that is a metadefinition. Such
definitions need not terminate but cannot be used in non-`meta` contexts.

Let us apply our custom tactic: -/

lemma any_goals_solve1_repeat_orelse_example₂ :
  even 4 ∧ even 7 ∧ even 3 ∧ even 0 :=
begin
  intro_and_even,
  repeat { sorry }
end

/- ## The Metaprogramming Monad

Tactics have access to

* the list of **goals** as metavariables (each metavariables has a type and a
  local context (hypothesis); they can optionally be instantiated);

* the **elaborator** (to elaborate expressions and compute their type);

* the **environment**, containing all declarations and inductive types;

* the **attributes** (e.g., the list of `@[simp]` rules).

The tactic monad is an alternative monad, with `fail` and `<|>`. Tactics can
also produce trace messages. -/

lemma even_14 :
  even 14 :=
by do
  tactic.trace "Proving evenness …",
  intro_and_even

meta def hello_then_intro_and_even : tactic unit :=
do
  tactic.trace "Proving evenness …",
  intro_and_even

lemma even_16 :
  even 16 :=
by hello_then_intro_and_even

run_cmd tactic.trace "Hello, Metaworld!"

meta def trace_goals : tactic unit :=
do
  tactic.trace "local context:",
  ctx ← tactic.local_context,
  tactic.trace ctx,
  tactic.trace "target:",
  P ← tactic.target,
  tactic.trace P,
  tactic.trace "all missing proofs:",
  Hs ← tactic.get_goals,
  tactic.trace Hs,
  τs ← list.mmap tactic.infer_type Hs,
  tactic.trace τs

lemma even_18_and_even_20 (α : Type) (a : α) :
  even 18 ∧ even 20 :=
by do
  tactic.applyc ``and.intro,
  trace_goals,
  intro_and_even

lemma triv_imp (a : Prop) (h : a) :
  a :=
by do
  h ← tactic.get_local `h,
  tactic.trace "h:",
  tactic.trace h,
  tactic.trace "raw h:",
  tactic.trace (expr.to_raw_fmt h),
  tactic.trace "type of h:",
  τ ← tactic.infer_type h,
  tactic.trace τ,
  tactic.trace "type of type of h:",
  υ ← tactic.infer_type τ,
  tactic.trace υ,
  tactic.apply h

meta def exact_list : list expr → tactic unit
| []        := tactic.fail "no matching expression found"
| (h :: hs) :=
  do {
    tactic.trace "trying",
    tactic.trace h,
    tactic.exact h }
  <|> exact_list hs

meta def hypothesis : tactic unit :=
do
  hs ← tactic.local_context,
  exact_list hs

lemma app_of_app {α : Type} {p : α → Prop} {a : α}
    (h : p a) :
  p a :=
by hypothesis

/- ## Names, Expressions, Declarations, and Environments

The metaprogramming framework is articulated around five main types:

* `tactic` manages the proof state, the global context, and more;

* `name` represents a structured name (e.g., `x`, `even.add_two`);

* `expr` represents an expression (a term) as an abstract syntax tree;

* `declaration` represents a constant declaration, a definition, an axiom, or a
  lemma;

* `environment` stores all the declarations and notations that make up the
  global context. -/

#print expr

#check expr tt  -- elaborated expressions
#check expr ff  -- unelaborated expressions (pre-expressions)

#print name

#check (expr.const `ℕ [] : expr)
#check expr.sort level.zero  -- Sort 0, i.e., Prop
#check expr.sort (level.succ level.zero)
  -- Sort 1, i.e., Type
#check expr.var 0  -- bound variable with De Bruijn index 0
#check (expr.local_const `uniq_name `pp_name binder_info.default
  `(ℕ) : expr)
#check (expr.mvar `uniq_name `pp_name `(ℕ) : expr)
#check (expr.pi `pp_name binder_info.default `(ℕ)
  (expr.sort level.zero) : expr)
#check (expr.lam `pp_name binder_info.default `(ℕ)
  (expr.var 0) : expr)
#check expr.elet
#check expr.macro

/- We can create literal expressions conveniently using backticks and
parentheses:

* Expressions with a single backtick must be fully elaborated.

* Expressions with two backticks are __pre-expressions__: They may contain some
  holes to be filled in later, based on some context.

* Expressions with three backticks are pre-expressions without name checking. -/

run_cmd do
  let e : expr := `(list.map (λn : ℕ, n + 1) [1, 2, 3]),
  tactic.trace e

run_cmd do
  let e : expr := `(list.map _ [1, 2, 3]),   -- fails
  tactic.trace e

run_cmd do
  let e₁ : pexpr := ``(list.map (λn, n + 1) [1, 2, 3]),
  let e₂ : pexpr := ``(list.map _ [1, 2, 3]),
  tactic.trace e₁,
  tactic.trace e₂

run_cmd do
  let e : pexpr := ```(seattle.washington),
  tactic.trace e

/- We can also create literal names with backticks:

* Names with a single backtick, `n, are not checked for existence.

* Names with two backticks, ``n, are resolved and checked. -/

run_cmd tactic.trace `and.intro
run_cmd tactic.trace `intro_and_even
run_cmd tactic.trace `seattle.washington

run_cmd tactic.trace ``and.intro
run_cmd tactic.trace ``intro_and_even
run_cmd tactic.trace ``seattle.washington   -- fails

/- __Antiquotations__ embed an existing expression in a larger expression. They
are announced by the prefix `%%` followed by a name from the current context.
Antiquotations are available with one, two, and three backticks: -/

run_cmd do
  let x : expr := `(2 : ℕ),
  let e : expr := `(%%x + 1),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ``(list.map %%x),
  tactic.trace e

run_cmd do
  let x : expr  := `(@id ℕ),
  let e : pexpr := ```(a _ %%x),
  tactic.trace e

lemma one_add_two_eq_three :
  1 + 2 = 3 :=
by do
  `(%%a + %%b = %%c) ← tactic.target,
  tactic.trace a,
  tactic.trace b,
  tactic.trace c,
  `(@eq %%α %%l %%r) ← tactic.target,
  tactic.trace α,
  tactic.trace l,
  tactic.trace r,
  tactic.exact `(refl _ : 3 = 3)

#print declaration

/- The `environment` type is presented as an abstract type, equipped with some
operations to query and modify it. The `environment.fold` metafunction iterates
over all declarations making up the environment. -/

run_cmd do
  env ← tactic.get_env,
  tactic.trace (environment.fold env 0 (λdecl n, n + 1))

/- ## First Example: A Conjuction-Destructing Tactic

We define a `destruct_and` tactic that automates the elimination of `∧` in
premises, automating proofs such as these: -/

lemma abcd_a (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  a :=
and.elim_left h

lemma abcd_b (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b :=
and.elim_left (and.elim_left (and.elim_right h))

lemma abcd_bc (a b c d : Prop) (h : a ∧ (b ∧ c) ∧ d) :
  b ∧ c :=
and.elim_left (and.elim_right h)

/- Our tactic relies on a helper metafunction, which takes as argument the
hypothesis `h` to use as an expression rather than as a name: -/

meta def destruct_and_helper : expr → tactic unit
| h :=
  do
    t ← tactic.infer_type h,
    match t with
    | `(%%a ∧ %%b) :=
      tactic.exact h
      <|>
      do {
        ha ← tactic.to_expr ``(and.elim_left %%h),
        destruct_and_helper ha }
      <|>
      do {
        hb ← tactic.to_expr ``(and.elim_right %%h),
        destruct_and_helper hb }
    | _            := tactic.exact h
    end

meta def destruct_and (nam : name) : tactic unit :=
do
  h ← tactic.get_local nam,
  destruct_and_helper h

/- Let us check that our tactic works: -/

lemma abc_a (a b c : Prop) (h : a ∧ b ∧ c) :
  a :=
by destruct_and `h

lemma abc_b (a b c : Prop) (h : a ∧ b ∧ c) :
  b :=
by destruct_and `h

lemma abc_bc (a b c : Prop) (h : a ∧ b ∧ c) :
  b ∧ c :=
by destruct_and `h

lemma abc_ac (a b c : Prop) (h : a ∧ b ∧ c) :
  a ∧ c :=
by destruct_and `h   -- fails

/- ## Second Example: A Provability Advisor

Next, we implement a `prove_direct` tool that traverses all lemmas in the
database and checks whether one of them can be used to prove the current goal. A
similar tactic is available in `mathlib` under the name `library_search`. -/

meta def is_theorem : declaration → bool
| (declaration.defn _ _ _ _ _ _) := ff
| (declaration.thm _ _ _ _)      := tt
| (declaration.cnst _ _ _ _)     := ff
| (declaration.ax _ _ _)         := tt

meta def get_all_theorems : tactic (list name) :=
do
  env ← tactic.get_env,
  pure (environment.fold env [] (λdecl nams,
    if is_theorem decl then declaration.to_name decl :: nams
    else nams))

meta def prove_with_name (nam : name) : tactic unit :=
do
  tactic.applyc nam
    ({ md := tactic.transparency.reducible, unify := ff }
     : tactic.apply_cfg),
  tactic.all_goals tactic.assumption,
  pure ()

meta def prove_direct : tactic unit :=
do
  nams ← get_all_theorems,
  list.mfirst (λnam,
      do
        prove_with_name nam,
        tactic.trace ("directly proved by " ++ to_string nam))
    nams

lemma nat.eq_symm (x y : ℕ) (h : x = y) :
  y = x :=
by prove_direct

lemma nat.eq_symm₂ (x y : ℕ) (h : x = y) :
  y = x :=
by library_search

lemma list.reverse_twice (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct

lemma list.reverse_twice_symm (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct   -- fails

/- As a small refinement, we propose a version of `prove_direct` that also
looks for equalities stated in symmetric form. -/

meta def prove_direct_symm : tactic unit :=
prove_direct
<|>
do {
  tactic.applyc `eq.symm,
  prove_direct }

lemma list.reverse_twice₂ (xs : list ℕ) :
  list.reverse (list.reverse xs) = xs :=
by prove_direct_symm

lemma list.reverse_twice_symm₂ (xs : list ℕ) :
  xs = list.reverse (list.reverse xs) :=
by prove_direct_symm

/- ## A Look at Two Predefined Tactics

Quite a few of Lean's predefined tactics are implemented as metaprograms and
not in C++. We can find these definitions by clicking the name of a construct
in Visual Studio Code while holding the control or command key. -/

#check tactic.intro
#check tactic.assumption

end LoVe


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
prelude
import init.logic

lemma punit_eq (a b : punit) : a = b :=
punit.rec_on a (punit.rec_on b rfl)

lemma punit_eq_star (a : punit) : a = punit.star :=
punit_eq a punit.star

instance : subsingleton punit :=
subsingleton.intro punit_eq

instance : inhabited punit :=
⟨punit.star⟩

instance : decidable_eq punit :=
λ a b, is_true (punit_eq a b)


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

/-!
# Traversable instances

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

universes u v

section option

open functor

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

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

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

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

variable (η : applicative_transformation F G)

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

end option

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

namespace list

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

section
variables [is_lawful_applicative F] [is_lawful_applicative G]

open applicative functor list

protected

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

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

variable (η : applicative_transformation F G)

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

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

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

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

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

variables [is_lawful_applicative F]

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

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

end traverse

end list

namespace sum

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

open applicative functor
open list (cons)

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

variables [is_lawful_applicative F] [is_lawful_applicative G]

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

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

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

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

variable (η : applicative_transformation F G)

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

end traverse

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

end sum


import Std.Tactic.SeqFocus

example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by
  constructor
  constructor
  -- error: too many tactics
  fail_if_success map_tacs [trivial, exact ⟨0, rfl⟩, trivial, trivial]
  -- error: not enough tactics
  fail_if_success map_tacs [trivial, exact ⟨0, rfl⟩]
  map_tacs [trivial, exact ⟨0, rfl⟩, trivial]

example : ((True ∧ True) ∧ (∃ x : Nat, x = x)) ∧ (True ∧ (∃ x : Nat, x = x)) := by
  constructor
  constructor
  map_tacs [(constructor; trivial), exact ⟨0, rfl⟩, constructor]
  trivial
  trivial
  exact ⟨0, rfl⟩

example : (True ∧ (∃ x : Nat, x = x)) ∧ True := by
  constructor
  -- error: not enough tactics
  fail_if_success constructor <;> [trivial]
  map_tacs [constructor <;> [trivial, exact ⟨0, rfl⟩], constructor]


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import algebra.group.defs
import control.functor

/-!
# `applicative` instances

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

This file provides `applicative` instances for concrete functors:
* `id`
* `functor.comp`
* `functor.const`
* `functor.add_const`
-/

universes u v w

section lemmas

open function

variables {F : Type u → Type v}
variables [applicative F] [is_lawful_applicative F]
variables {α β γ σ : Type u}

lemma applicative.map_seq_map (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) :
  (f <$> x) <*> (g <$> y) = (flip (∘) g ∘ f) <$> x <*> y :=
by simp [flip] with functor_norm

lemma applicative.pure_seq_eq_map' (f : α → β) : (<*>) (pure f : F (α → β)) = (<$>) f :=
by ext; simp with functor_norm

theorem applicative.ext {F} : ∀ {A1 : applicative F} {A2 : applicative F}
  [@is_lawful_applicative F A1] [@is_lawful_applicative F A2]
  (H1 : ∀ {α : Type u} (x : α),
    @has_pure.pure _ A1.to_has_pure _ x = @has_pure.pure _ A2.to_has_pure _ x)
  (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α),
    @has_seq.seq _ A1.to_has_seq _ _ f x = @has_seq.seq _ A2.to_has_seq _ _ f x),
  A1 = A2
| {to_functor := F1, seq := s1, pure := p1, seq_left := sl1, seq_right := sr1}
  {to_functor := F2, seq := s2, pure := p2, seq_left := sl2, seq_right := sr2} L1 L2 H1 H2 :=
begin
  obtain rfl : @p1 = @p2, {funext α x, apply H1},
  obtain rfl : @s1 = @s2, {funext α β f x, apply H2},
  cases L1, cases L2,
  obtain rfl : F1 = F2,
  { resetI, apply functor.ext, intros,
    exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _) },
  congr; funext α β x y,
  { exact (L1_seq_left_eq _ _).trans (L2_seq_left_eq _ _).symm },
  { exact (L1_seq_right_eq _ _).trans (L2_seq_right_eq _ _).symm }
end

end lemmas

instance : is_comm_applicative id :=
by refine { .. }; intros; refl

namespace functor
namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

variables [is_lawful_applicative F] [is_lawful_applicative G]
variables {α β γ : Type v}

lemma map_pure (f : α → β) (x : α) : (f <$> pure x : comp F G β) = pure (f x) :=
comp.ext $ by simp

lemma seq_pure (f : comp F G (α → β)) (x : α) :
  f <*> pure x = (λ g : α → β, g x) <$> f :=
comp.ext $ by simp [(∘)] with functor_norm

lemma pure_seq_eq_map (f : α → β) (x : comp F G α) :
  pure f <*> x = f <$> x :=
comp.ext $ by simp [applicative.pure_seq_eq_map'] with functor_norm

instance : is_lawful_applicative (comp F G) :=
{ pure_seq_eq_map := @comp.pure_seq_eq_map F G _ _ _ _,
  map_pure := @comp.map_pure F G _ _ _ _,
  seq_pure := @comp.seq_pure F G _ _ _ _,
  seq_assoc := @comp.seq_assoc F G _ _ _ _ }

theorem applicative_id_comp {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative id F _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative id F _ _ _ _) _
  (λ α x, rfl) (λ α β f x, rfl)

theorem applicative_comp_id {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative F id _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative F id _ _ _ _) _
  (λ α x, rfl) (λ α β f x, show id <$> f <*> x = f <*> x, by rw id_map)

open is_comm_applicative

instance {f : Type u → Type w} {g : Type v → Type u}
  [applicative f] [applicative g]
  [is_comm_applicative f] [is_comm_applicative g] :
  is_comm_applicative (comp f g) :=
by { refine { .. @comp.is_lawful_applicative f g _ _ _ _, .. },
     intros, casesm* comp _ _ _, simp! [map,has_seq.seq] with functor_norm,
     rw [commutative_map],
     simp [comp.mk,flip,(∘)] with functor_norm,
     congr, funext, rw [commutative_map], congr }

end comp
end functor

open functor

@[functor_norm]
lemma comp.seq_mk {α β : Type w}
  {f : Type u → Type v} {g : Type w → Type u}
  [applicative f] [applicative g]
  (h : f (g (α → β))) (x : f (g α)) :
  comp.mk h <*> comp.mk x = comp.mk (has_seq.seq <$> h <*> x) := rfl

instance {α} [has_one α] [has_mul α] : applicative (const α) :=
{ pure := λ β x, (1 : α),
  seq := λ β γ f x, (f * x : α) }

instance {α} [monoid α] : is_lawful_applicative (const α) :=
by refine { .. }; intros; simp [mul_assoc, (<$>), (<*>), pure]

instance {α} [has_zero α] [has_add α] : applicative (add_const α) :=
{ pure := λ β x, (0 : α),
  seq := λ β γ f x, (f + x : α) }

instance {α} [add_monoid α] : is_lawful_applicative (add_const α) :=
by refine { .. }; intros; simp [add_assoc, (<$>), (<*>), pure]


import Lean
syntax (name := test) "test%" ident : command

open Lean.Elab
open Lean.Elab.Command

@[commandElab test] def elabTest : CommandElab := fun stx => do
  let id ← resolveGlobalConstNoOverloadWithInfo stx[1]
  liftTermElabM none do
    IO.println (repr (← Lean.Meta.Match.getEquationsFor id))
  return ()

def f (x : List Nat) : Nat :=
  match x with
  | [] => 1
  | [a] => 2
  | _ => 3

test% f.match_1
#check @f.match_1
#check @f.match_1.splitter

theorem ex (x : List Nat) : f x > 0 := by
  simp [f]
  split <;> decide

test% Std.RBNode.balance1.match_1
#check @Std.RBNode.balance1.match_1.splitter


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

Facts about epimorphisms and monomorphisms.

The definitions of `epi` and `mono` are in `category_theory.category`,
since they are used by some lemmas for `iso`, which is used everywhere.
-/
import category_theory.adjunction.basic
import category_theory.opposites

universes v₁ v₂ u₁ u₂

namespace category_theory

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

section
variables {D : Type u₂} [category.{v₂} D]

lemma left_adjoint_preserves_epi {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
  {X Y : C} {f : X ⟶ Y} (hf : epi f) : epi (F.map f) :=
begin
  constructor,
  intros Z g h H,
  replace H := congr_arg (adj.hom_equiv X Z) H,
  rwa [adj.hom_equiv_naturality_left, adj.hom_equiv_naturality_left,
    cancel_epi, equiv.apply_eq_iff_eq] at H
end

lemma right_adjoint_preserves_mono {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
  {X Y : D} {f : X ⟶ Y} (hf : mono f) : mono (G.map f) :=
begin
  constructor,
  intros Z g h H,
  replace H := congr_arg (adj.hom_equiv Z Y).symm H,
  rwa [adj.hom_equiv_naturality_right_symm, adj.hom_equiv_naturality_right_symm,
    cancel_mono, equiv.apply_eq_iff_eq] at H
end

instance is_equivalence.epi_map {F : C ⥤ D} [is_left_adjoint F] {X Y : C} {f : X ⟶ Y}
  [h : epi f] : epi (F.map f) :=
left_adjoint_preserves_epi (adjunction.of_left_adjoint F) h

instance is_equivalence.mono_map {F : C ⥤ D} [is_right_adjoint F] {X Y : C} {f : X ⟶ Y}
  [h : mono f] : mono (F.map f) :=
right_adjoint_preserves_mono (adjunction.of_right_adjoint F) h

lemma faithful_reflects_epi (F : C ⥤ D) [faithful F] {X Y : C} {f : X ⟶ Y}
  (hf : epi (F.map f)) : epi f :=
⟨λ Z g h H, F.map_injective $
  by rw [←cancel_epi (F.map f), ←F.map_comp, ←F.map_comp, H]⟩

lemma faithful_reflects_mono (F : C ⥤ D) [faithful F] {X Y : C} {f : X ⟶ Y}
  (hf : mono (F.map f)) : mono f :=
⟨λ Z g h H, F.map_injective $
  by rw [←cancel_mono (F.map f), ←F.map_comp, ←F.map_comp, H]⟩
end

/--
A split monomorphism is a morphism `f : X ⟶ Y` admitting a retraction `retraction f : Y ⟶ X`
such that `f ≫ retraction f = 𝟙 X`.

Every split monomorphism is a monomorphism.
-/
class split_mono {X Y : C} (f : X ⟶ Y) :=
(retraction : Y ⟶ X)
(id' : f ≫ retraction = 𝟙 X . obviously)

/--
A split epimorphism is a morphism `f : X ⟶ Y` admitting a section `section_ f : Y ⟶ X`
such that `section_ f ≫ f = 𝟙 Y`.
(Note that `section` is a reserved keyword, so we append an underscore.)

Every split epimorphism is an epimorphism.
-/
class split_epi {X Y : C} (f : X ⟶ Y) :=
(section_ : Y ⟶ X)
(id' : section_ ≫ f = 𝟙 Y . obviously)

/-- The chosen retraction of a split monomorphism. -/
def retraction {X Y : C} (f : X ⟶ Y) [split_mono f] : Y ⟶ X := split_mono.retraction f
@[simp, reassoc]
lemma split_mono.id {X Y : C} (f : X ⟶ Y) [split_mono f] : f ≫ retraction f = 𝟙 X :=
split_mono.id'
/-- The retraction of a split monomorphism is itself a split epimorphism. -/
instance retraction_split_epi {X Y : C} (f : X ⟶ Y) [split_mono f] : split_epi (retraction f) :=
{ section_ := f }

/-- A split mono which is epi is an iso. -/
lemma is_iso_of_epi_of_split_mono {X Y : C} (f : X ⟶ Y) [split_mono f] [epi f] : is_iso f :=
⟨⟨retraction f, ⟨by simp, by simp [← cancel_epi f]⟩⟩⟩

/--
The chosen section of a split epimorphism.
(Note that `section` is a reserved keyword, so we append an underscore.)
-/
def section_ {X Y : C} (f : X ⟶ Y) [split_epi f] : Y ⟶ X := split_epi.section_ f
@[simp, reassoc]
lemma split_epi.id {X Y : C} (f : X ⟶ Y) [split_epi f] : section_ f ≫ f = 𝟙 Y :=
split_epi.id'
/-- The section of a split epimorphism is itself a split monomorphism. -/
instance section_split_mono {X Y : C} (f : X ⟶ Y) [split_epi f] : split_mono (section_ f) :=
{ retraction := f }

/-- A split epi which is mono is an iso. -/
lemma is_iso_of_mono_of_split_epi {X Y : C} (f : X ⟶ Y) [mono f] [split_epi f] : is_iso f :=
⟨⟨section_ f, ⟨by simp [← cancel_mono f], by simp⟩⟩⟩

/-- Every iso is a split mono. -/
@[priority 100]
noncomputable
instance split_mono.of_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : split_mono f :=
{ retraction := inv f }

/-- Every iso is a split epi. -/
@[priority 100]
noncomputable
instance split_epi.of_iso {X Y : C} (f : X ⟶ Y) [is_iso f] : split_epi f :=
{ section_ := inv f }

/-- Every split mono is a mono. -/
@[priority 100]
instance split_mono.mono {X Y : C} (f : X ⟶ Y) [split_mono f] : mono f :=
{ right_cancellation := λ Z g h w, begin replace w := w =≫ retraction f, simpa using w, end }

/-- Every split epi is an epi. -/
@[priority 100]
instance split_epi.epi {X Y : C} (f : X ⟶ Y) [split_epi f] : epi f :=
{ left_cancellation := λ Z g h w, begin replace w := section_ f ≫= w, simpa using w, end }

/-- Every split mono whose retraction is mono is an iso. -/
lemma is_iso.of_mono_retraction {X Y : C} {f : X ⟶ Y} [split_mono f] [mono $ retraction f]
  : is_iso f :=
⟨⟨retraction f, ⟨by simp, (cancel_mono_id $ retraction f).mp (by simp)⟩⟩⟩

/-- Every split epi whose section is epi is an iso. -/
lemma is_iso.of_epi_section {X Y : C} {f : X ⟶ Y} [split_epi f] [epi $ section_ f]
  : is_iso f :=
⟨⟨section_ f, ⟨(cancel_epi_id $ section_ f).mp (by simp), by simp⟩⟩⟩

instance unop_mono_of_epi {A B : Cᵒᵖ} (f : A ⟶ B) [epi f] : mono f.unop :=
⟨λ Z g h eq, quiver.hom.op_inj ((cancel_epi f).1 (quiver.hom.unop_inj eq))⟩

instance unop_epi_of_mono {A B : Cᵒᵖ} (f : A ⟶ B) [mono f] : epi f.unop :=
⟨λ Z g h eq, quiver.hom.op_inj ((cancel_mono f).1 (quiver.hom.unop_inj eq))⟩

instance op_mono_of_epi {A B : C} (f : A ⟶ B) [epi f] : mono f.op :=
⟨λ Z g h eq, quiver.hom.unop_inj ((cancel_epi f).1 (quiver.hom.op_inj eq))⟩

instance op_epi_of_mono {A B : C} (f : A ⟶ B) [mono f] : epi f.op :=
⟨λ Z g h eq, quiver.hom.unop_inj ((cancel_mono f).1 (quiver.hom.op_inj eq))⟩

section
variables {D : Type u₂} [category.{v₂} D]

/-- Split monomorphisms are also absolute monomorphisms. -/
instance {X Y : C} (f : X ⟶ Y) [split_mono f] (F : C ⥤ D) : split_mono (F.map f) :=
{ retraction := F.map (retraction f),
  id' := by { rw [←functor.map_comp, split_mono.id, functor.map_id], } }

/-- Split epimorphisms are also absolute epimorphisms. -/
instance {X Y : C} (f : X ⟶ Y) [split_epi f] (F : C ⥤ D) : split_epi (F.map f) :=
{ section_ := F.map (section_ f),
  id' := by { rw [←functor.map_comp, split_epi.id, functor.map_id], } }
end

end category_theory


structure A where
  x : Nat
  w : Nat

structure B extends A where
  y : Nat

structure C extends B where
  z : Nat

def f1 (c : C) (a : A) : C :=
  { c with toA := a, x := 0 }  -- Error, `toA` and `x` are both updates to field `x`

def f2 (c : C) (a : A) : C :=
  { c with toA := a }

def f3 (c : C) (a : A) : C :=
  { a, c with x := 0 }

theorem ex1 (a : A) (c : C) : (f3 c a).x = 0 :=
  rfl

theorem ex2 (a : A) (c : C) : (f3 c a).w = a.w :=
  rfl

def f4 (c : C) (a : A) : C :=
  { c, a with x := 0 } -- TODO: generate error that `a` was not used?

theorem ex3 (a : A) (c : C) : (f4 c a).w = c.w :=
  rfl

theorem ex4 (a : A) (c : C) : (f4 c a).x = 0 :=
  rfl

def f5 (c : C) (a : A) :=
  { c, a with x := 0 }

#check f5

def f6 (c : C) (a : A) :=
  { a, c with x := 0 }

#check f6


/-
Copyright (c) 2015 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura

Quotient types.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.sigma.basic
import Mathlib.Lean3Lib.init.logic
import Mathlib.Lean3Lib.init.propext
import Mathlib.Lean3Lib.init.data.setoid

universes u v u_a u_b u_c

namespace Mathlib

/- We import propext here, otherwise we would need a quot.lift for propositions. -/

-- iff can now be used to do substitutions in a calculation

theorem iff_subst {a : Prop} {b : Prop} {p : Prop → Prop} (h₁ : a ↔ b) (h₂ : p a) : p b :=
  propext h₁ ▸ h₂

namespace quot

axiom sound {α : Sort u} {r : α → α → Prop} {a : α} {b : α} : r a b → Quot.mk r a = Quot.mk r bprotected theorem lift_beta {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) (c : ∀ (a b : α), r a b → f a = f b) (a : α) : Quot.lift f c (Quot.mk r a) = f a :=
  rfl

protected theorem ind_beta {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (p : ∀ (a : α), β (Quot.mk r a)) (a : α) : Quot.ind p (Quot.mk r a) = p a :=
  rfl

protected def lift_on {α : Sort u} {β : Sort v} {r : α → α → Prop} (q : Quot r) (f : α → β) (c : ∀ (a b : α), r a b → f a = f b) : β :=
  Quot.lift f c q

protected theorem induction_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Prop} (q : Quot r) (h : ∀ (a : α), β (Quot.mk r a)) : β q :=
  Quot.ind h q

theorem exists_rep {α : Sort u} {r : α → α → Prop} (q : Quot r) : ∃ (a : α), Quot.mk r a = q :=
  quot.induction_on q fun (a : α) => Exists.intro a rfl

protected def indep {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (a : α) : psigma β :=
  psigma.mk (Quot.mk r a) (f a)

protected theorem indep_coherent {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (a : α) (b : α) : r a b → quot.indep f a = quot.indep f b :=
  fun (e : r a b) => psigma.eq (sound e) (h a b e)

protected theorem lift_indep_pr1 {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (q : Quot r) : psigma.fst (Quot.lift (quot.indep f) (quot.indep_coherent f h) q) = q :=
  Quot.ind (fun (a : α) => Eq.refl (psigma.fst (quot.indep f a))) q

protected def rec {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) (q : Quot r) : β q :=
  eq.rec_on (quot.lift_indep_pr1 f h q) (psigma.snd (Quot.lift (quot.indep f) (quot.indep_coherent f h) q))

protected def rec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r) (f : (a : α) → β (Quot.mk r a)) (h : ∀ (a b : α) (p : r a b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec f h q

protected def rec_on_subsingleton {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} [h : ∀ (a : α), subsingleton (β (Quot.mk r a))] (q : Quot r) (f : (a : α) → β (Quot.mk r a)) : β q :=
  quot.rec f sorry q

protected def hrec_on {α : Sort u} {r : α → α → Prop} {β : Quot r → Sort v} (q : Quot r) (f : (a : α) → β (Quot.mk r a)) (c : ∀ (a b : α), r a b → f a == f b) : β q :=
  quot.rec_on q f sorry

end quot

def quotient {α : Sort u} (s : setoid α) :=
  Quot setoid.r

namespace quotient

protected def mk {α : Sort u} [s : setoid α] (a : α) : quotient s :=
  Quot.mk setoid.r a

def sound {α : Sort u} [s : setoid α] {a : α} {b : α} : a ≈ b → quotient.mk a = quotient.mk b :=
  quot.sound

protected def lift {α : Sort u} {β : Sort v} [s : setoid α] (f : α → β) : (∀ (a b : α), a ≈ b → f a = f b) → quotient s → β :=
  Quot.lift f

protected theorem ind {α : Sort u} [s : setoid α] {β : quotient s → Prop} : (∀ (a : α), β (quotient.mk a)) → ∀ (q : quotient s), β q :=
  Quot.ind

protected def lift_on {α : Sort u} {β : Sort v} [s : setoid α] (q : quotient s) (f : α → β) (c : ∀ (a b : α), a ≈ b → f a = f b) : β :=
  quot.lift_on q f c

protected theorem induction_on {α : Sort u} [s : setoid α] {β : quotient s → Prop} (q : quotient s) (h : ∀ (a : α), β (quotient.mk a)) : β q :=
  quot.induction_on q h

theorem exists_rep {α : Sort u} [s : setoid α] (q : quotient s) : ∃ (a : α), quotient.mk a = q :=
  quot.exists_rep q

protected def rec {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (f : (a : α) → β (quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) (q : quotient s) : β q :=
  quot.rec f h q

protected def rec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s) (f : (a : α) → β (quotient.mk a)) (h : ∀ (a b : α) (p : a ≈ b), Eq._oldrec (f a) (sound p) = f b) : β q :=
  quot.rec_on q f h

protected def rec_on_subsingleton {α : Sort u} [s : setoid α] {β : quotient s → Sort v} [h : ∀ (a : α), subsingleton (β (quotient.mk a))] (q : quotient s) (f : (a : α) → β (quotient.mk a)) : β q :=
  quot.rec_on_subsingleton q f

protected def hrec_on {α : Sort u} [s : setoid α] {β : quotient s → Sort v} (q : quotient s) (f : (a : α) → β (quotient.mk a)) (c : ∀ (a b : α), a ≈ b → f a == f b) : β q :=
  quot.hrec_on q f c

protected def lift₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] (f : α → β → φ) (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) (q₁ : quotient s₁) (q₂ : quotient s₂) : φ :=
  quotient.lift (fun (a₁ : α) => quotient.lift (f a₁) sorry q₂) sorry q₁

protected def lift_on₂ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] (q₁ : quotient s₁) (q₂ : quotient s₂) (f : α → β → φ) (c : ∀ (a₁ : α) (a₂ : β) (b₁ : α) (b₂ : β), a₁ ≈ b₁ → a₂ ≈ b₂ → f a₁ a₂ = f b₁ b₂) : φ :=
  quotient.lift₂ f c q₁ q₂

protected theorem ind₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Prop} (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) (q₁ : quotient s₁) (q₂ : quotient s₂) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (h : ∀ (a : α) (b : β), φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => h a₁ a₂) q₂) q₁

protected theorem induction_on₃ {α : Sort u_a} {β : Sort u_b} {φ : Sort u_c} [s₁ : setoid α] [s₂ : setoid β] [s₃ : setoid φ] {δ : quotient s₁ → quotient s₂ → quotient s₃ → Prop} (q₁ : quotient s₁) (q₂ : quotient s₂) (q₃ : quotient s₃) (h : ∀ (a : α) (b : β) (c : φ), δ (quotient.mk a) (quotient.mk b) (quotient.mk c)) : δ q₁ q₂ q₃ :=
  quotient.ind (fun (a₁ : α) => quotient.ind (fun (a₂ : β) => quotient.ind (fun (a₃ : φ) => h a₁ a₂ a₃) q₃) q₂) q₁

theorem exact {α : Sort u} [s : setoid α] {a : α} {b : α} : quotient.mk a = quotient.mk b → a ≈ b :=
  fun (h : quotient.mk a = quotient.mk b) => eq_imp_rel h

protected def rec_on_subsingleton₂ {α : Sort u_a} {β : Sort u_b} [s₁ : setoid α] [s₂ : setoid β] {φ : quotient s₁ → quotient s₂ → Sort u_c} [h : ∀ (a : α) (b : β), subsingleton (φ (quotient.mk a) (quotient.mk b))] (q₁ : quotient s₁) (q₂ : quotient s₂) (f : (a : α) → (b : β) → φ (quotient.mk a) (quotient.mk b)) : φ q₁ q₂ :=
  quotient.rec_on_subsingleton q₁ fun (a : α) => quotient.rec_on_subsingleton q₂ fun (b : β) => f a b

end quotient

inductive eqv_gen {α : Type u} (r : α → α → Prop) : α → α → Prop
where
| rel : ∀ (x y : α), r x y → eqv_gen r x y
| refl : ∀ (x : α), eqv_gen r x x
| symm : ∀ (x y : α), eqv_gen r x y → eqv_gen r y x
| trans : ∀ (x y z : α), eqv_gen r x y → eqv_gen r y z → eqv_gen r x z

theorem eqv_gen.is_equivalence {α : Type u} (r : α → α → Prop) : equivalence (eqv_gen r) :=
  mk_equivalence (eqv_gen r) eqv_gen.refl eqv_gen.symm eqv_gen.trans

def eqv_gen.setoid {α : Type u} (r : α → α → Prop) : setoid α :=
  setoid.mk (eqv_gen r) (eqv_gen.is_equivalence r)

theorem quot.exact {α : Type u} (r : α → α → Prop) {a : α} {b : α} (H : Quot.mk r a = Quot.mk r b) : eqv_gen r a b :=
  quotient.exact (congr_arg (Quot.lift quotient.mk fun (x y : α) (h : r x y) => quot.sound (eqv_gen.rel x y h)) H)

theorem quot.eqv_gen_sound {α : Type u} {r : α → α → Prop} {a : α} {b : α} (H : eqv_gen r a b) : Quot.mk r a = Quot.mk r b := sorry

protected instance quotient.decidable_eq {α : Sort u} {s : setoid α} [d : (a b : α) → Decidable (a ≈ b)] : DecidableEq (quotient s) :=
  fun (q₁ q₂ : quotient s) => quotient.rec_on_subsingleton₂ q₁ q₂ fun (a₁ a₂ : α) => sorry


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro
-/
import tactic.ext

open interactive

namespace tactic

/-
This file defines a `chain` tactic, which takes a list of tactics,
and exhaustively tries to apply them to the goals, until no tactic succeeds on any goal.

Along the way, it generates auxiliary declarations, in order to speed up elaboration time
of the resulting (sometimes long!) proofs.

This tactic is used by the `tidy` tactic.
-/

-- α is the return type of our tactics. When `chain` is called by `tidy`, this is string,
-- describing what that tactic did as an interactive tactic.
variable {α : Type}

inductive tactic_script (α : Type) : Type
| base : α → tactic_script
| work (index : ℕ) (first : α) (later : list tactic_script) (closed : bool) : tactic_script

meta def tactic_script.to_string : tactic_script string → string
| (tactic_script.base a) := a
| (tactic_script.work n a l c) :=  "work_on_goal " ++ (to_string n) ++
    " { " ++ (", ".intercalate (a :: l.map tactic_script.to_string)) ++ " }"

meta instance : has_to_string (tactic_script string) :=
{ to_string := λ s, s.to_string }

meta instance tactic_script_unit_has_to_string : has_to_string (tactic_script unit) :=
{ to_string := λ s, "[chain tactic]" }

meta def abstract_if_success (tac : expr → tactic α) (g : expr) : tactic α :=
do
  type ← infer_type g,
  is_lemma ← is_prop type,
  if is_lemma then -- there's no point making the abstraction, and indeed it's slower
    tac g
  else do
    m ← mk_meta_var type,
    a ← tac m,
    do
    { val ← instantiate_mvars m,
      guard (val.list_meta_vars = []),
      c  ← new_aux_decl_name,
      gs ← get_goals,
      set_goals [g],
      add_aux_decl c type val ff >>= unify g,
      set_goals gs }
    <|> unify m g,
    return a

/--
`chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
-/
meta mutual def chain_single, chain_many, chain_iter {α} (tac : tactic α)
with chain_single : expr → tactic (α × list (tactic_script α)) | g :=
do set_goals [g],
  a ← tac,
  l ← get_goals >>= chain_many,
  return (a, l)
with chain_many : list expr → tactic (list (tactic_script α))
| [] := return []
| [g] := do
{ (a, l) ← chain_single g,
  return (tactic_script.base a :: l) } <|> return []
| gs := chain_iter gs []
with chain_iter : list expr → list expr → tactic (list (tactic_script α))
| [] _ := return []
| (g :: later_goals) stuck_goals := do
{ (a, l) ← abstract_if_success chain_single g,
  new_goals ← get_goals,
  let w := tactic_script.work stuck_goals.length a l (new_goals = []),
  let current_goals := stuck_goals.reverse ++ new_goals ++ later_goals,
  set_goals current_goals, -- we keep the goals up to date, so they are correct at the end
  l' ← chain_many current_goals,
  return (w :: l') } <|> chain_iter later_goals (g :: stuck_goals)

meta def chain_core {α : Type} [has_to_string (tactic_script α)] (tactics : list (tactic α)) :
  tactic (list string) :=
do results ← (get_goals >>= chain_many (first tactics)),
   when results.empty (fail "`chain` tactic made no progress"),
   return (results.map to_string)

variables [has_to_string (tactic_script α)] [has_to_format α]

declare_trace chain

meta def trace_output (t : tactic α) : tactic α :=
do tgt ← target,
   r ← t,
   name ← decl_name,
   trace format!"`chain` successfully applied a tactic during elaboration of {name}:",
   tgt ← pp tgt,
   trace format!"previous target: {tgt}",
   trace format!"tactic result: {r}",
   tgt ← try_core target,
   tgt ← match tgt with
          | (some tgt) := pp tgt
          | none       := return "no goals"
          end,
   trace format!"new target: {tgt}",
   pure r

meta def chain (tactics : list (tactic α)) : tactic (list string) :=
chain_core
  (if is_trace_enabled_for `chain then (tactics.map trace_output) else tactics)

end tactic


import data.polya.field

namespace tactic

meta def pexpr_of_pos_num (α h_one h_add : expr) : pos_num → pexpr
| pos_num.one      := ``(@has_one.one %%α %%h_one)
| (pos_num.bit0 n) := ``(@bit0 %%α %%h_add (%%(pexpr_of_pos_num n)))
| (pos_num.bit1 n) := ``(@bit1 %%α %%h_one %%h_add (%%(pexpr_of_pos_num n)))

meta def expr_of_num (α : expr) (n : num) : tactic expr :=
match n with
| num.zero := do
  h_zero ← mk_app `has_zero [α] >>= mk_instance,
  to_expr ``(@has_zero.zero %%α %%h_zero)
| (num.pos (pos_num.one)) := do
  h_one ← mk_app `has_one [α] >>= mk_instance,
  to_expr ``(@has_one.one %%α %%h_one)
| (num.pos m) := do
  h_one ← mk_app `has_one [α] >>= mk_instance,
  h_add ← mk_app `has_add [α] >>= mk_instance,
  to_expr (pexpr_of_pos_num α h_one h_add m)
end

meta def expr_of_znum (α : expr) (n : znum) : tactic expr :=
match n with
| znum.zero := do
  h_zero ← mk_app `has_zero [α] >>= mk_instance,
  to_expr ``(@has_zero.zero %%α %%h_zero)
| (znum.pos n) :=
  expr_of_num α (num.pos n)
| (znum.neg n) := do
  h_neg ← mk_app `has_neg [α] >>= mk_instance,
  e ← expr_of_num α (num.pos n),
  to_expr ``(@has_neg.neg %%α %%h_neg %%e)
end

meta def expr_of_rat (α : expr) (q : ℚ) : tactic expr :=
let n : znum := q.num in
let d : znum := q.denom in
if d = 1 then
  expr_of_znum α n
else do
  a ← expr_of_znum α n,
  b ← expr_of_znum α d,
  to_expr ``(%%a / %%b)

end tactic

namespace rat

open polya.field

instance : const_space ℚ :=
{ df := by apply_instance,
  lt := (<),
  dec := by apply_instance,
}

instance {α} [discrete_field α] [char_zero α] : morph ℚ α :=
{ cast       := by apply_instance,
  morph_zero := rat.cast_zero,
  morph_one  := rat.cast_one,
  morph_add  := rat.cast_add,
  morph_neg  := rat.cast_neg,
  morph_mul  := rat.cast_mul,
  morph_inv  := rat.cast_inv,
  morph_inj  := begin
      intros a ha,
      apply rat.cast_inj.mp,
      { rw rat.cast_zero, apply ha },
      { resetI, apply_instance }
    end,
}

end rat

namespace list

def pall {α : Type*} (l : list α) (f : α → Prop) : Prop :=
l.foldr (λ a r, f a ∧ r) true

theorem pall_iff_forall_prop :
  ∀ {α : Type*} {p : α → Prop} [_inst_1 : decidable_pred p] {l : list α},
  list.pall l p ↔ ∀ (a : α), a ∈ l → p a :=
begin
  intros,
  apply iff.trans, swap,
  { exact @list.all_iff_forall_prop _ _ _inst_1 _ },
  { unfold pall, induction l with x xs ih,
    { simp },
    { simp [ih] }}
end

open polya.field tactic

meta def expr_reflect (type : expr) : list expr → tactic expr
| [] := to_expr ``([] : list %%type)
| (h::t) := do e ← expr_reflect t, to_expr ``(list.cons (%%h : %%type) %%e)

def to_dict {α} [inhabited α] (l : list α) : dict α :=
⟨λ i, list.func.get i l.reverse⟩

end list

--namespace finmap
--open field
--
--def to_dict {α} [discrete_field α] (m : finmap (λ _ : num, α)) : dict α :=
--⟨λ i, match finmap.lookup i m with (some x) := x | _ := 0 end⟩
--
--end finmap

namespace tactic
open native tactic

namespace polya.field
open polya.field polya.field.term

meta structure cache_ty :=
( new_atom : num )
( atoms    : rb_map expr num )
( dict     : rb_map num expr )

meta instance : has_emptyc cache_ty :=
⟨⟨0, rb_map.mk _ _, rb_map.mk _ _⟩⟩

meta def state_dict : Type → Type := state_t cache_ty tactic

namespace state_dict
meta instance : monad state_dict := state_t.monad
meta instance : monad_state cache_ty state_dict := state_t.monad_state
meta instance : alternative state_dict := state_t.alternative
meta instance {α} : has_coe (tactic α) (state_dict α) := ⟨state_t.lift⟩
end state_dict

meta def get_atom (e : expr) : state_dict num :=
get >>= λ s,
match s.atoms.find e with
| (some i) := return i
| none     := do
    let i := s.new_atom,
    put ⟨i + 1, s.atoms.insert e i, s.dict.insert i e⟩,
    return i
end

meta def cache_ty.dict_expr (α : expr) (s : cache_ty) : tactic expr :=
do
    e ← s.dict.values.expr_reflect α,
    mk_app `list.to_dict [e]

meta def term_of_expr : expr → state_dict term | e :=
match e with
| `(%%a + %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (add x y)
| `(%%a - %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (sub x y)
| `(%%a * %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (mul x y)
| `(%%a / %%b) := do y ← term_of_expr b, x ← term_of_expr a, return (div x y)
| `(-%%a)      := do x ← term_of_expr a, return (neg x)
| `((%%a)⁻¹)   := do x ← term_of_expr a, return (inv x)
| `(%%a ^ %%b) := do x ← term_of_expr a, ( (do n ← b.to_nat, return (pow_nat x n)) <|> (do n ← b.to_int, return (pow_int x n)) )
| _            := do n ← e.to_nat, return (numeral n)
end <|> do i ← get_atom e, return (atom i)

--TODO: more generic
@[reducible] def α := ℚ
@[reducible] def γ := ℚ

meta def nterm_to_expr (s : cache_ty) : nterm γ → tactic expr
| (nterm.atom i)  := s.dict.find i
| (nterm.const c) := expr_of_rat `(α) c
| (nterm.add x y) := do a ← nterm_to_expr x, b ← nterm_to_expr y, to_expr ``(%%a + %%b)
| (nterm.mul x y) := do a ← nterm_to_expr x, b ← nterm_to_expr y, to_expr ``(%%a * %%b)
| (nterm.pow x n) := do a ← nterm_to_expr x, b ← expr_of_znum `(ℤ) n, to_expr ``(%%a ^ %%b)

meta def prove_norm_hyps (t : term) (s : cache_ty) : tactic (list expr × expr) :=
do
  let t_expr : expr := reflect t,
  ρ ← s.dict_expr `(α),

  let nhyps := norm_hyps γ t,
  nhyps ← monad.mapm (nterm_to_expr s) nhyps,
  nhyps ← monad.mapm (λ e, to_expr ``(%%e ≠ 0)) nhyps,
  mvars ← monad.mapm mk_meta_var nhyps,

  h ← to_expr ``(∀ x ∈ norm_hyps γ %%t_expr, nterm.eval %%ρ x ≠ 0),
  pe ← to_expr ( mvars.foldr (λ e pe, ``((and.intro %%e %%pe))) ``(trivial) ) tt ff,
  ((), pr) ← solve_aux h (refine ``(list.pall_iff_forall_prop.mp _) >> exact pe >> done),

  return (mvars, pr)

-- norm_expr e s = (new_e, pr, mv, mvs, new_s)
-- new_e is the canonized expression
-- pr is a proof that e = new_e
-- mv is a meta-variable to prove by reflexivity
-- mvs are neta-variables for the nonzero hypothesis made by the normalizer
-- new_s is the updated cache
meta def norm_expr (e : expr) (s : cache_ty) :
  tactic (expr × expr × expr × list expr × cache_ty) :=
do
  (t, s) ← (term_of_expr e).run s,
  let t_expr : expr := reflect t,
  let norm_t := norm γ t,
  norm_t_expr ← to_expr ``(norm γ %%t_expr),
  ρ_expr ← s.dict_expr `(α),

  (mvars, pr0) ← prove_norm_hyps t s,

  --reflexivity from expr to term
  h1 ← to_expr ``(%%e = term.eval %%ρ_expr %%t_expr),
  ((), pr1) ← solve_aux h1 `[refl, done],

  --correctness theorem
  --h2 ← to_expr ``(term.eval %%ρ_expr %%t_expr = nterm.eval %%ρ_expr %%norm_t_expr),
  pr2 ← mk_app `polya.field.correctness [pr0],

  --reflexivity from nterm to expr
  new_e ← nterm_to_expr s norm_t,
  h3 ← to_expr ``(nterm.eval %%ρ_expr %%norm_t_expr = %%new_e),
  pr3 ← mk_meta_var h3, --heavy computation in the kernel

  pr ← mk_eq_trans pr2 pr3 >>= mk_eq_trans pr1,
  return (new_e, pr, pr3, mvars, s)

end polya.field

meta def prove_by_reflexivity (mvs : list expr) : tactic unit :=
do
  gs ← get_goals,
  set_goals mvs,
  all_goals reflexivity,
  set_goals gs

end tactic

open tactic interactive interactive.types lean.parser
open tactic.polya.field

meta def tactic.interactive.field1 : tactic unit :=
do
  `(%%e1 = %%e2) ← target,

  (new_e1, pr1, mv1, mvs, s) ← norm_expr e1 ∅,
  (new_e2, pr2, mv2, mvs', s) ← norm_expr e2 s,

  ( do
    unify new_e1 new_e2,
    prove_by_reflexivity [mv1, mv2],
    gs ← get_goals,
    set_goals (gs ++ mvs ++ mvs'),
    pr ← mk_eq_symm pr2 >>= mk_eq_trans pr1,
    tactic.exact pr
  ) <|> ( do
    prove_by_reflexivity [mv1, mv2],
    pr0 ← to_expr ``(%%new_e1 = %%new_e2) >>= mk_meta_var,
    gs ← get_goals,
    set_goals (gs ++ [pr0] ++ mvs ++ mvs'),
    pr ← mk_eq_symm pr2 >>= mk_eq_trans pr0 >>= mk_eq_trans pr1,
    tactic.exact pr
  )


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta, Adam Topaz
-/
import category_theory.functor_category
import category_theory.fully_faithful

namespace category_theory
open category

universes v₁ u₁ -- morphism levels before object levels. See note [category_theory universes].

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

/--
The data of a monad on C consists of an endofunctor T together with natural transformations
η : 𝟭 C ⟶ T and μ : T ⋙ T ⟶ T satisfying three equations:
- T μ_X ≫ μ_X = μ_(TX) ≫ μ_X (associativity)
- η_(TX) ≫ μ_X = 1_X (left unit)
- Tη_X ≫ μ_X = 1_X (right unit)
-/
structure monad extends C ⥤ C :=
(η' [] : 𝟭 _ ⟶ to_functor)
(μ' [] : to_functor ⋙ to_functor ⟶ to_functor)
(assoc' : ∀ X, to_functor.map (nat_trans.app μ' X) ≫ μ'.app _ = μ'.app _ ≫ μ'.app _ . obviously)
(left_unit' : ∀ X : C, η'.app (to_functor.obj X) ≫ μ'.app _ = 𝟙 _ . obviously)
(right_unit' : ∀ X : C, to_functor.map (η'.app X) ≫ μ'.app _ = 𝟙 _ . obviously)

/--
The data of a comonad on C consists of an endofunctor G together with natural transformations
ε : G ⟶ 𝟭 C and δ : G ⟶ G ⋙ G satisfying three equations:
- δ_X ≫ G δ_X = δ_X ≫ δ_(GX) (coassociativity)
- δ_X ≫ ε_(GX) = 1_X (left counit)
- δ_X ≫ G ε_X = 1_X (right counit)
-/
structure comonad extends C ⥤ C :=
(ε' [] : to_functor ⟶ 𝟭 _)
(δ' [] : to_functor ⟶ to_functor ⋙ to_functor)
(coassoc' : ∀ X, nat_trans.app δ' _ ≫ to_functor.map (δ'.app X) = δ'.app _ ≫ δ'.app _ . obviously)
(left_counit' : ∀ X : C, δ'.app X ≫ ε'.app (to_functor.obj X) = 𝟙 _ . obviously)
(right_counit' : ∀ X : C, δ'.app X ≫ to_functor.map (ε'.app X) = 𝟙 _ . obviously)

variables {C} (T : monad C) (G : comonad C)

instance coe_monad : has_coe (monad C) (C ⥤ C) := ⟨λ T, T.to_functor⟩
instance coe_comonad : has_coe (comonad C) (C ⥤ C) := ⟨λ G, G.to_functor⟩

@[simp] lemma monad_to_functor_eq_coe : T.to_functor = T := rfl
@[simp] lemma comonad_to_functor_eq_coe : G.to_functor = G := rfl

/-- The unit for the monad `T`. -/
def monad.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η'
/-- The multiplication for the monad `T`. -/
def monad.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ T := T.μ'

/-- The counit for the comonad `G`. -/
def comonad.ε : (G : C ⥤ C) ⟶ 𝟭 _  := G.ε'
/-- The comultiplication for the comonad `G`. -/
def comonad.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ G := G.δ'

/-- A custom simps projection for the functor part of a monad, as a coercion. -/
def monad.simps.coe := (T : C ⥤ C)
/-- A custom simps projection for the unit of a monad, in simp normal form. -/
def monad.simps.η : 𝟭 _ ⟶ (T : C ⥤ C) := T.η
/-- A custom simps projection for the multiplication of a monad, in simp normal form. -/
def monad.simps.μ : (T : C ⥤ C) ⋙ (T : C ⥤ C) ⟶ (T : C ⥤ C) := T.μ

/-- A custom simps projection for the functor part of a comonad, as a coercion. -/
def comonad.simps.coe := (G : C ⥤ C)
/-- A custom simps projection for the counit of a comonad, in simp normal form. -/
def comonad.simps.ε : (G : C ⥤ C) ⟶ 𝟭 _ := G.ε
/-- A custom simps projection for the comultiplication of a comonad, in simp normal form. -/
def comonad.simps.δ : (G : C ⥤ C) ⟶ (G : C ⥤ C) ⋙ (G : C ⥤ C) := G.δ

initialize_simps_projections category_theory.monad (to_functor → coe, η' → η, μ' → μ)
initialize_simps_projections category_theory.comonad (to_functor → coe, ε' → ε, δ' → δ)

@[reassoc]
lemma monad.assoc (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.μ.app X) ≫ T.μ.app _ = T.μ.app _ ≫ T.μ.app _ :=
T.assoc' X

@[simp, reassoc] lemma monad.left_unit (T : monad C) (X : C) :
  T.η.app ((T : C ⥤ C).obj X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.left_unit' X

@[simp, reassoc] lemma monad.right_unit (T : monad C) (X : C) :
  (T : C ⥤ C).map (T.η.app X) ≫ T.μ.app X = 𝟙 ((T : C ⥤ C).obj X) :=
T.right_unit' X

@[reassoc]
lemma comonad.coassoc (G : comonad C) (X : C) :
  G.δ.app _ ≫ (G : C ⥤ C).map (G.δ.app X) = G.δ.app _ ≫ G.δ.app _ :=
G.coassoc' X

@[simp, reassoc] lemma comonad.left_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ G.ε.app ((G : C ⥤ C).obj X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.left_counit' X

@[simp, reassoc] lemma comonad.right_counit (G : comonad C) (X : C) :
  G.δ.app X ≫ (G : C ⥤ C).map (G.ε.app X) = 𝟙 ((G : C ⥤ C).obj X) :=
G.right_counit' X

/-- A morphism of monads is a natural transformation compatible with η and μ. -/
@[ext]
structure monad_hom (T₁ T₂ : monad C) extends nat_trans (T₁ : C ⥤ C) T₂ :=
(app_η' : ∀ {X}, T₁.η.app X ≫ app X = T₂.η.app X . obviously)
(app_μ' : ∀ {X}, T₁.μ.app X ≫ app X = ((T₁ : C ⥤ C).map (app X) ≫ app _) ≫ T₂.μ.app X . obviously)

/-- A morphism of comonads is a natural transformation compatible with ε and δ. -/
@[ext]
structure comonad_hom (M N : comonad C) extends nat_trans (M : C ⥤ C) N :=
(app_ε' : ∀ {X}, app X ≫ N.ε.app X = M.ε.app X . obviously)
(app_δ' : ∀ {X}, app X ≫ N.δ.app X = M.δ.app X ≫ app (M.obj X) ≫ N.map (app X) . obviously)

restate_axiom monad_hom.app_η'
restate_axiom monad_hom.app_μ'
attribute [simp, reassoc] monad_hom.app_η monad_hom.app_μ

restate_axiom comonad_hom.app_ε'
restate_axiom comonad_hom.app_δ'
attribute [simp, reassoc] comonad_hom.app_ε comonad_hom.app_δ

instance : category (monad C) :=
{ hom := monad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ _ _ _ f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance : category (comonad C) :=
{ hom := comonad_hom,
  id := λ M, { to_nat_trans := 𝟙 (M : C ⥤ C) },
  comp := λ M N L f g,
  { to_nat_trans := { app := λ X, f.app X ≫ g.app X } } }

instance {T : monad C} : inhabited (monad_hom T T) := ⟨𝟙 T⟩

@[simp]

instance {G : comonad C} : inhabited (comonad_hom G G) := ⟨𝟙 G⟩

@[simp] lemma comonad_hom.id_to_nat_trans (T : comonad C) :
  (𝟙 T : T ⟶ T).to_nat_trans = 𝟙 (T : C ⥤ C) :=
rfl
@[simp] lemma comp_to_nat_trans {T₁ T₂ T₃ : comonad C} (f : T₁ ⟶ T₂) (g : T₂ ⟶ T₃) :
  (f ≫ g).to_nat_trans =
    ((f.to_nat_trans : _ ⟶ (T₂ : C ⥤ C)) ≫ g.to_nat_trans : (T₁ : C ⥤ C) ⟶ T₃) :=
rfl

variable (C)

/--
The forgetful functor from the category of monads to the category of endofunctors.
-/
@[simps]
def monad_to_functor : monad C ⥤ (C ⥤ C) :=
{ obj := λ T, T,
  map := λ M N f, f.to_nat_trans }

instance : faithful (monad_to_functor C) := {}.

/--
The forgetful functor from the category of comonads to the category of endofunctors.
-/
@[simps]
def comonad_to_functor : comonad C ⥤ (C ⥤ C) :=
{ obj := λ G, G,
  map := λ M N f, f.to_nat_trans }

instance : faithful (comonad_to_functor C) := {}.

variable {C}

/--
An isomorphism of monads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def monad_iso.to_nat_iso {M N : monad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(monad_to_functor C).map_iso h

/--
An isomorphism of comonads gives a natural isomorphism of the underlying functors.
-/
@[simps {rhs_md := semireducible}]
def comonad_iso.to_nat_iso {M N : comonad C} (h : M ≅ N) : (M : C ⥤ C) ≅ N :=
(comonad_to_functor C).map_iso h

variable (C)

namespace monad

/-- The identity monad. -/
@[simps]
def id : monad C :=
{ to_functor := 𝟭 C,
  η' := 𝟙 (𝟭 C),
  μ' := 𝟙 (𝟭 C) }

instance : inhabited (monad C) := ⟨monad.id C⟩

end monad

namespace comonad

/-- The identity comonad. -/
@[simps]
def id : comonad C :=
{ to_functor := 𝟭 _,
  ε' := 𝟙 (𝟭 C),
  δ' := 𝟙 (𝟭 C) }

instance : inhabited (comonad C) := ⟨comonad.id C⟩

end comonad

end category_theory


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

Additional equiv and encodable instances for lists, finsets, and fintypes.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.denumerable
import Mathlib.data.finset.sort
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

namespace encodable

def encode_list {α : Type u_1} [encodable α] : List α → ℕ :=
  sorry

def decode_list {α : Type u_1} [encodable α] : ℕ → Option (List α) :=
  sorry

protected instance list {α : Type u_1} [encodable α] : encodable (List α) :=
  mk encode_list decode_list sorry

@[simp] theorem encode_list_nil {α : Type u_1} [encodable α] : encode [] = 0 :=
  rfl

@[simp] theorem encode_list_cons {α : Type u_1} [encodable α] (a : α) (l : List α) : encode (a :: l) = Nat.succ (nat.mkpair (encode a) (encode l)) :=
  rfl

@[simp] theorem decode_list_zero {α : Type u_1} [encodable α] : decode (List α) 0 = some [] :=
  rfl

@[simp] theorem decode_list_succ {α : Type u_1} [encodable α] (v : ℕ) : decode (List α) (Nat.succ v) =
  (fun (_x : α) (_y : List α) => _x :: _y) <$> decode α (prod.fst (nat.unpair v)) <*>
    decode (List α) (prod.snd (nat.unpair v)) := sorry

theorem length_le_encode {α : Type u_1} [encodable α] (l : List α) : list.length l ≤ encode l := sorry

def encode_multiset {α : Type u_1} [encodable α] (s : multiset α) : ℕ :=
  encode (multiset.sort enle s)

def decode_multiset {α : Type u_1} [encodable α] (n : ℕ) : Option (multiset α) :=
  coe <$> decode (List α) n

protected instance multiset {α : Type u_1} [encodable α] : encodable (multiset α) :=
  mk encode_multiset decode_multiset sorry

def encodable_of_list {α : Type u_1} [DecidableEq α] (l : List α) (H : ∀ (x : α), x ∈ l) : encodable α :=
  mk (fun (a : α) => list.index_of a l) (list.nth l) sorry

def trunc_encodable_of_fintype (α : Type u_1) [DecidableEq α] [fintype α] : trunc (encodable α) :=
  quot.rec_on_subsingleton (finset.val finset.univ)
    (fun (l : List α) (H : ∀ (x : α), x ∈ Quot.mk setoid.r l) => trunc.mk (encodable_of_list l H)) finset.mem_univ

/-- A noncomputable way to arbitrarily choose an ordering on a finite type.
  It is not made into a global instance, since it involves an arbitrary choice.
  This can be locally made into an instance with `local attribute [instance] fintype.encodable`. -/
def fintype.encodable (α : Type u_1) [fintype α] : encodable α :=
  trunc.out (trunc_encodable_of_fintype α)

protected instance vector {α : Type u_1} [encodable α] {n : ℕ} : encodable (vector α n) :=
  encodable.subtype

protected instance fin_arrow {α : Type u_1} [encodable α] {n : ℕ} : encodable (fin n → α) :=
  of_equiv (vector α n) (equiv.symm (equiv.vector_equiv_fin α n))

protected instance fin_pi (n : ℕ) (π : fin n → Type u_1) [(i : fin n) → encodable (π i)] : encodable ((i : fin n) → π i) :=
  of_equiv (↥(set_of fun (f : fin n → sigma fun (i : fin n) => π i) => ∀ (i : fin n), sigma.fst (f i) = i))
    (equiv.pi_equiv_subtype_sigma (fin n) π)

protected instance array {α : Type u_1} [encodable α] {n : ℕ} : encodable (array n α) :=
  of_equiv (fin n → α) (equiv.array_equiv_fin n α)

protected instance finset {α : Type u_1} [encodable α] : encodable (finset α) :=
  of_equiv (Subtype fun (s : multiset α) => multiset.nodup s)
    (equiv.mk (fun (_x : finset α) => sorry) (fun (_x : Subtype fun (s : multiset α) => multiset.nodup s) => sorry) sorry
      sorry)

def fintype_arrow (α : Type u_1) (β : Type u_2) [DecidableEq α] [fintype α] [encodable β] : trunc (encodable (α → β)) :=
  trunc.map
    (fun (f : α ≃ fin (fintype.card α)) => of_equiv (fin (fintype.card α) → β) (equiv.arrow_congr f (equiv.refl β)))
    (fintype.equiv_fin α)

def fintype_pi (α : Type u_1) (π : α → Type u_2) [DecidableEq α] [fintype α] [(a : α) → encodable (π a)] : trunc (encodable ((a : α) → π a)) :=
  trunc.bind (trunc_encodable_of_fintype α)
    fun (a : encodable α) =>
      trunc.bind (fintype_arrow α (sigma fun (a : α) => π a))
        fun (f : encodable (α → sigma fun (a : α) => π a)) =>
          trunc.mk
            (of_equiv
              (Subtype
                fun (a : α → sigma fun (a : α) => π a) =>
                  a ∈ set_of fun (f : α → sigma fun (a : α) => π a) => ∀ (i : α), sigma.fst (f i) = i)
              (equiv.pi_equiv_subtype_sigma α π))

/-- The elements of a `fintype` as a sorted list. -/
def sorted_univ (α : Type u_1) [fintype α] [encodable α] : List α :=
  finset.sort (⇑(encode' α) ⁻¹'o LessEq) finset.univ

theorem mem_sorted_univ {α : Type u_1} [fintype α] [encodable α] (x : α) : x ∈ sorted_univ α :=
  iff.mpr (finset.mem_sort (⇑(encode' α) ⁻¹'o LessEq)) (finset.mem_univ x)

theorem length_sorted_univ {α : Type u_1} [fintype α] [encodable α] : list.length (sorted_univ α) = fintype.card α :=
  finset.length_sort (⇑(encode' α) ⁻¹'o LessEq)

theorem sorted_univ_nodup {α : Type u_1} [fintype α] [encodable α] : list.nodup (sorted_univ α) :=
  finset.sort_nodup (⇑(encode' α) ⁻¹'o LessEq) finset.univ

/-- An encodable `fintype` is equivalent a `fin`.-/
def fintype_equiv_fin {α : Type u_1} [fintype α] [encodable α] : α ≃ fin (fintype.card α) :=
  equiv.trans (fintype.equiv_fin_of_forall_mem_list mem_sorted_univ sorted_univ_nodup) (equiv.cast sorry)

protected instance fintype_arrow_of_encodable {α : Type u_1} {β : Type u_2} [encodable α] [fintype α] [encodable β] : encodable (α → β) :=
  of_equiv (fin (fintype.card α) → β) (equiv.arrow_congr fintype_equiv_fin (equiv.refl β))

end encodable

namespace denumerable

theorem denumerable_list_aux {α : Type u_1} [denumerable α] (n : ℕ) : ∃ (a : List α), ∃ (H : a ∈ encodable.decode_list n), encodable.encode_list a = n := sorry

protected instance denumerable_list {α : Type u_1} [denumerable α] : denumerable (List α) :=
  mk denumerable_list_aux

@[simp] theorem list_of_nat_zero {α : Type u_1} [denumerable α] : of_nat (List α) 0 = [] :=
  rfl

@[simp] theorem list_of_nat_succ {α : Type u_1} [denumerable α] (v : ℕ) : of_nat (List α) (Nat.succ v) = of_nat α (prod.fst (nat.unpair v)) :: of_nat (List α) (prod.snd (nat.unpair v)) := sorry

def lower : List ℕ → ℕ → List ℕ :=
  sorry

def raise : List ℕ → ℕ → List ℕ :=
  sorry

theorem lower_raise (l : List ℕ) (n : ℕ) : lower (raise l n) n = l := sorry

theorem raise_lower {l : List ℕ} {n : ℕ} : list.sorted LessEq (n :: l) → raise (lower l n) n = l := sorry

theorem raise_chain (l : List ℕ) (n : ℕ) : list.chain LessEq n (raise l n) := sorry

theorem raise_sorted (l : List ℕ) (n : ℕ) : list.sorted LessEq (raise l n) := sorry

/- Warning: this is not the same encoding as used in `encodable` -/

protected instance multiset {α : Type u_1} [denumerable α] : denumerable (multiset α) :=
  mk'
    (equiv.mk
      (fun (s : multiset α) => encodable.encode (lower (multiset.sort LessEq (multiset.map encodable.encode s)) 0))
      (fun (n : ℕ) => multiset.map (of_nat α) ↑(raise (of_nat (List ℕ) n) 0)) sorry sorry)

def lower' : List ℕ → ℕ → List ℕ :=
  sorry

def raise' : List ℕ → ℕ → List ℕ :=
  sorry

theorem lower_raise' (l : List ℕ) (n : ℕ) : lower' (raise' l n) n = l := sorry

theorem raise_lower' {l : List ℕ} {n : ℕ} : (∀ (m : ℕ), m ∈ l → n ≤ m) → list.sorted Less l → raise' (lower' l n) n = l := sorry

theorem raise'_chain (l : List ℕ) {m : ℕ} {n : ℕ} : m < n → list.chain Less m (raise' l n) := sorry

theorem raise'_sorted (l : List ℕ) (n : ℕ) : list.sorted Less (raise' l n) := sorry

def raise'_finset (l : List ℕ) (n : ℕ) : finset ℕ :=
  finset.mk ↑(raise' l n) sorry

/- Warning: this is not the same encoding as used in `encodable` -/

protected instance finset {α : Type u_1} [denumerable α] : denumerable (finset α) :=
  mk'
    (equiv.mk
      (fun (s : finset α) => encodable.encode (lower' (finset.sort LessEq (finset.map (equiv.to_embedding (eqv α)) s)) 0))
      (fun (n : ℕ) => finset.map (equiv.to_embedding (equiv.symm (eqv α))) (raise'_finset (of_nat (List ℕ) n) 0)) sorry
      sorry)

end denumerable

namespace equiv

/-- The type lists on unit is canonically equivalent to the natural numbers. -/
def list_unit_equiv : List Unit ≃ ℕ :=
  mk list.length (list.repeat Unit.unit) sorry sorry

def list_nat_equiv_nat : List ℕ ≃ ℕ :=
  denumerable.eqv (List ℕ)

def list_equiv_self_of_equiv_nat {α : Type} (e : α ≃ ℕ) : List α ≃ α :=
  equiv.trans (equiv.trans (list_equiv_of_equiv e) list_nat_equiv_nat) (equiv.symm e)


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.category.Cat
import category_theory.limits.types
import category_theory.limits.preserves.basic

/-!
# The category of small categories has all small limits.

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

An object in the limit consists of a family of objects,
which are carried to one another by the functors in the diagram.
A morphism between two such objects is a family of morphisms between the corresponding objects,
which are carried to one another by the action on morphisms of the functors in the diagram.

## Future work
Can the indexing category live in a lower universe?
-/

noncomputable theory

universes v u

open category_theory.limits

namespace category_theory

variables {J : Type v} [small_category J]

namespace Cat

namespace has_limits

instance category_objects {F : J ⥤ Cat.{u u}} {j} :
  small_category ((F ⋙ Cat.objects.{u u}).obj j) :=
(F.obj j).str

/-- Auxiliary definition:
the diagram whose limit gives the morphism space between two objects of the limit category. -/
@[simps]
def hom_diagram {F : J ⥤ Cat.{v v}} (X Y : limit (F ⋙ Cat.objects.{v v})) : J ⥤ Type v :=
{ obj := λ j, limit.π (F ⋙ Cat.objects) j X ⟶ limit.π (F ⋙ Cat.objects) j Y,
  map := λ j j' f g,
  begin
    refine eq_to_hom _ ≫ (F.map f).map g ≫ eq_to_hom _,
    exact (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm,
    exact (congr_fun (limit.w (F ⋙ Cat.objects) f) Y),
  end,
  map_id' := λ X, begin
    ext f, dsimp,
    simp [functor.congr_hom (F.map_id X) f],
  end,
  map_comp' := λ X Y Z f g, begin
    ext h, dsimp,
    simp [functor.congr_hom (F.map_comp f g) h, eq_to_hom_map],
    refl,
  end, }

@[simps]
instance (F : J ⥤ Cat.{v v}) : category (limit (F ⋙ Cat.objects)) :=
{ hom := λ X Y, limit (hom_diagram X Y),
  id := λ X, types.limit.mk.{v v} (hom_diagram X X) (λ j, 𝟙 _) (λ j j' f, by simp),
  comp := λ X Y Z f g, types.limit.mk.{v v} (hom_diagram X Z)
    (λ j, limit.π (hom_diagram X Y) j f ≫ limit.π (hom_diagram Y Z) j g)
    (λ j j' h, begin
      rw [←congr_fun (limit.w (hom_diagram X Y) h) f, ←congr_fun (limit.w (hom_diagram Y Z) h) g],
      dsimp,
      simp,
    end),
  id_comp' := λ _ _ _, by { ext, simp only [category.id_comp, types.limit.π_mk'] },
  comp_id' := λ _ _ _, by { ext, simp only [types.limit.π_mk', category.comp_id] } }

/-- Auxiliary definition: the limit category. -/
@[simps]
def limit_cone_X (F : J ⥤ Cat.{v v}) : Cat.{v v} :=
{ α := limit (F ⋙ Cat.objects), }.

/-- Auxiliary definition: the cone over the limit category. -/
@[simps]
def limit_cone (F : J ⥤ Cat.{v v}) : cone F :=
{ X := limit_cone_X F,
  π :=
  { app := λ j,
    { obj := limit.π (F ⋙ Cat.objects) j,
      map := λ X Y, limit.π (hom_diagram X Y) j, },
    naturality' := λ j j' f, category_theory.functor.ext
      (λ X, (congr_fun (limit.w (F ⋙ Cat.objects) f) X).symm)
      (λ X Y h, (congr_fun (limit.w (hom_diagram X Y) f) h).symm), } }

/-- Auxiliary definition: the universal morphism to the proposed limit cone. -/
@[simps]
def limit_cone_lift (F : J ⥤ Cat.{v v}) (s : cone F) : s.X ⟶ limit_cone_X F :=
{ obj := limit.lift (F ⋙ Cat.objects)
  { X := s.X,
    π :=
    { app := λ j, (s.π.app j).obj,
      naturality' := λ j j' f, (congr_arg functor.obj (s.π.naturality f) : _), } },
  map := λ X Y f,
  begin
    fapply types.limit.mk.{v v},
    { intro j,
      refine eq_to_hom _ ≫ (s.π.app j).map f ≫ eq_to_hom _;
      simp, },
    { intros j j' h,
      dsimp,
      simp only [category.assoc, functor.map_comp,
        eq_to_hom_map, eq_to_hom_trans, eq_to_hom_trans_assoc],
      rw [←functor.comp_map],
      have := (s.π.naturality h).symm,
      conv at this { congr, skip, dsimp, simp, },
      erw [functor.congr_hom this f],
      dsimp, simp, },
  end,
  map_id' := λ X, by simp,
  map_comp' := λ X Y Z f g, by simp }

@[simp]
lemma limit_π_hom_diagram_eq_to_hom {F : J ⥤ Cat.{v v}}
  (X Y : limit (F ⋙ Cat.objects.{v v})) (j : J) (h : X = Y) :
  limit.π (hom_diagram X Y) j (eq_to_hom h) =
    eq_to_hom (congr_arg (limit.π (F ⋙ Cat.objects.{v v}) j) h) :=
by { subst h, simp, }

/-- Auxiliary definition: the proposed cone is a limit cone. -/
def limit_cone_is_limit (F : J ⥤ Cat.{v v}) : is_limit (limit_cone F) :=
{ lift := limit_cone_lift F,
  fac' := λ s j, category_theory.functor.ext (by tidy) (λ X Y f, types.limit.π_mk _ _ _ _),
  uniq' := λ s m w,
  begin
    symmetry,
    fapply category_theory.functor.ext,
    { intro X,
      ext,
      dsimp, simp only [types.limit.lift_π_apply', ←w j],
      refl, },
    { intros X Y f,
      dsimp, simp [(λ j, functor.congr_hom (w j).symm f)],
      congr, },
  end, }

end has_limits

/-- The category of small categories has all small limits. -/
instance : has_limits (Cat.{v v}) :=
{ has_limits_of_shape := λ J _, by exactI
  { has_limit := λ F, ⟨⟨⟨has_limits.limit_cone F, has_limits.limit_cone_is_limit F⟩⟩⟩, } }

instance : preserves_limits Cat.objects.{v v} :=
{ preserves_limits_of_shape := λ J _, by exactI
  { preserves_limit := λ F,
    preserves_limit_of_preserves_limit_cone (has_limits.limit_cone_is_limit F)
      (limits.is_limit.of_iso_limit (limit.is_limit (F ⋙ Cat.objects))
        (cones.ext (by refl) (by tidy))), }}

end Cat

end category_theory