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

! This file was ported from Lean 3 source module algebra.hierarchy_design
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Tactic.DocCommands

/-!
# Documentation of the algebraic hierarchy

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

A library note giving advice on modifying the algebraic hierarchy.
(It is not intended as a "tour".)

TODO: Add sections about interactions with topological typeclasses, and order typeclasses.

-/

library_note "the algebraic hierarchy"/-- # The algebraic hierarchy

In any theorem proving environment,
there are difficult decisions surrounding the design of the "algebraic hierarchy".

There is a danger of exponential explosion in the number of gadgets,
especially once interactions between algebraic and order/topological/etc structures are considered.

In mathlib, we try to avoid this by only introducing new algebraic typeclasses either
1. when there is "real mathematics" to be done with them, or
2. when there is a meaninful gain in simplicity by factoring out a common substructure.

(As examples, at this point we don't have `loop`, or `unital_magma`,
but we do have `lie_submodule` and `topological_field`!
We also have `group_with_zero`, as an exemplar of point 2.)

Generally in mathlib we use the extension mechanism (so `comm_ring` extends `ring`)
rather than mixins (e.g. with separate `ring` and `comm_mul` classes),
in part because of the potential blow-up in term sizes described at
https://www.ralfj.de/blog/2019/05/15/typeclasses-exponential-blowup.html
However there is tension here, as it results in considerable duplication in the API,
particularly in the interaction with order structures.

This library note is not intended as a design document
justifying and explaining the history of mathlib's algebraic hierarchy!
Instead it is intended as a developer's guide, for contributors wanting to extend
(either new leaves, or new intermediate classes) the algebraic hierarchy as it exists.

(Ideally we would have both a tour guide to the existing hierarchy,
and an account of the design choices.
See https://arxiv.org/abs/1910.09336 for an overview of mathlib as a whole,
with some attention to the algebraic hierarchy and
https://leanprover-community.github.io/mathlib-overview.html
for a summary of what is in mathlib today.)

## Instances

When adding a new typeclass `Z` to the algebraic hierarchy
one should attempt to add the following constructions and results,
when applicable:

* Instances transferred elementwise to products, like `prod.monoid`.
  See `algebra.group.prod` for more examples.
  ```
  instance prod.Z [Z M] [Z N] : Z (M × N) := ...
  ```
* Instances transferred elementwise to pi types, like `pi.monoid`.
  See `algebra.group.pi` for more examples.
  ```
  instance pi.Z [∀ i, Z $ f i] : Z (Π i : I, f i) := ...
  ```
* Instances transferred to `mul_opposite M`, like `mul_opposite.monoid`.
  See `algebra.opposites` for more examples.
  ```
  instance mul_opposite.Z [Z M] : Z (mul_opposite M) := ...
  ```
* Instances transferred to `ulift M`, like `ulift.monoid`.
  See `algebra.group.ulift` for more examples.
  ```
  instance ulift.Z [Z M] : Z (ulift M) := ...
  ```
* Definitions for transferring the proof fields of instances along
  injective or surjective functions that agree on the data fields,
  like `function.injective.monoid` and `function.surjective.monoid`.
  We make these definitions `@[reducible]`, see note [reducible non-instances].
  See `algebra.group.inj_surj` for more examples.
  ```
  @[reducible]
  def function.injective.Z [Z M₂] (f : M₁ → M₂) (hf : injective f)
    (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) : Z M₁ := ...

  @[reducible]
  def function.surjective.Z [Z M₁] (f : M₁ → M₂) (hf : surjective f)
    (one : f 1 = 1) (mul : ∀ x y, f (x * y) = f x * f y) : Z M₂ := ...
  ```
* Instances transferred elementwise to `finsupp`s, like `finsupp.semigroup`.
  See `data.finsupp.pointwise` for more examples.
  ```
  instance finsupp.Z [Z β] : Z (α →₀ β) := ...
  ```
* Instances transferred elementwise to `set`s, like `set.monoid`.
  See `algebra.pointwise` for more examples.
  ```
  instance set.Z [Z α] : Z (set α) := ...
  ```
* Definitions for transferring the entire structure across an equivalence, like `equiv.monoid`.
  See `data.equiv.transfer_instance` for more examples. See also the `transport` tactic.
  ```
  def equiv.Z (e : α ≃ β) [Z β] : Z α := ...
  /- When there is a new notion of `Z`-equiv: -/
  def equiv.Z_equiv (e : α ≃ β) [Z β] : by { letI := equiv.Z e, exact α ≃Z β } := ...
  ```

## Subobjects

When a new typeclass `Z` adds new data fields,
you should also create a new `sub_Z` `structure` with a `carrier` field.

This can be a lot of work; for now try to closely follow the existing examples
(e.g. `submonoid`, `subring`, `subalgebra`).
We would very much like to provide some automation here, but a prerequisite will be making
all the existing APIs more uniform.

If `Z` extends `Y`, then `sub_Z` should usually extend `sub_Y`.

When `Z` adds only new proof fields to an existing structure `Y`,
you should provide instances transferring
`Z α` to `Z (sub_Y α)`, like `submonoid.to_comm_monoid`.
Typically this is done using the `function.injective.Z` definition mentioned above.
```
instance sub_Y.to_Z [Z α] : Z (sub_Y α) :=
coe_injective.Z coe ...
```

## Morphisms and equivalences

## Category theory

For many algebraic structures, particularly ones used in representation theory, algebraic geometry,
etc., we also define "bundled" versions, which carry `category` instances.

These bundled versions are usually named in camel case,
so for example we have `AddCommGroup` as a bundled `add_comm_group`,
and `TopCommRing` (which bundles together `comm_ring`, `topological_space`, and `topological_ring`).

These bundled versions have many appealing features:
* a uniform notation for morphisms `X ⟶ Y`
* a uniform notation (and definition) for isomorphisms `X ≅ Y`
* a uniform API for subobjects, via the partial order `subobject X`
* interoperability with unbundled structures, via coercions to `Type`
  (so if `G : AddCommGroup`, you can treat `G` as a type,
  and it automatically has an `add_comm_group` instance)
  and lifting maps `AddCommGroup.of G`, when `G` is a type with an `add_comm_group` instance.

If, for example you do the work of proving that a typeclass `Z` has a good notion of tensor product,
you are strongly encouraged to provide the corresponding `monoidal_category` instance
on a bundled version.
This ensures that the API for tensor products is complete, and enables use of general machinery.
Similarly if you prove universal properties, or adjunctions, you are encouraged to state these
using categorical language!

One disadvantage of the bundled approach is that we can only speak of morphisms between
objects living in the same type-theoretic universe.
In practice this is rarely a problem.

# Making a pull request

With so many moving parts, how do you actually go about changing the algebraic hierarchy?

We're still evolving how to handle this, but the current suggestion is:

* If you're adding a new "leaf" class, the requirements are lower,
  and an initial PR can just add whatever is immediately needed.
* A new "intermediate" class, especially low down in the hierarchy,
  needs to be careful about leaving gaps.

In a perfect world, there would be a group of simultaneous PRs that basically cover everything!
(Or at least an expectation that PRs may not be merged immediately while waiting on other
PRs that fill out the API.)

However "perfect is the enemy of good", and it would also be completely reasonable
to add a TODO list in the main module doc-string for the new class,
briefly listing the parts of the API which still need to be provided.
Hopefully this document makes it easy to assemble this list.

Another alternative to a TODO list in the doc-strings is adding github issues.

-/

library_note "reducible non-instances"/--
Some definitions that define objects of a class cannot be instances, because they have an
explicit argument that does not occur in the conclusion. An example is `preorder.lift` that has a
function `f : α → β` as an explicit argument to lift a preorder on `β` to a preorder on `α`.

If these definitions are used to define instances of this class *and* this class is an argument to
some other type-class so that type-class inference will have to unfold these instances to check
for definitional equality, then these definitions should be marked `@[reducible]`.

For example, `preorder.lift` is used to define `units.preorder` and `partial_order.lift` is used
to define `units.partial_order`. In some cases it is important that type-class inference can
recognize that `units.preorder` and `units.partial_order` give rise to the same `has_le` instance.
For example, you might have another class that takes `[has_le α]` as an argument, and this argument
sometimes comes from `units.preorder` and sometimes from `units.partial_order`.
Therefore, `preorder.lift` and `partial_order.lift` are marked `@[reducible]`.
-/


import SciLean.Tactic.CustomSimp.Main

import Lean.Meta
import Lean.Parser
import Lean.Elab

-- namespace Lean.Elab.Tactic
open Lean Meta Simp

namespace SciLean.Meta.DebugSimp

def pre (e : Expr) : SimpM Step := do
  trace[Meta.Tactic.simp] "Running pre on {← ppExpr e}"
  pure (Step.visit (Result.mk e none 0))

def post (e : Expr) : SimpM Step := do
  trace[Meta.Tactic.simp] "Running post on {← ppExpr e}"
  pure (Step.visit (Result.mk e none 0))

open Lean.Parser.Tactic in
syntax (name := debug_simp) "debug_simp " (config)? (discharger)? (&"only ")? ("[" (simpStar <|> simpErase <|> simpLemma),* "]")? (location)? : tactic

open Lean.Elab.Tactic in
@[tactic debug_simp] def evalDebugSimp : Tactic := fun stx => do
  let { ctx, dischargeWrapper } ← withMainContext <| mkSimpContext stx (eraseLocal := false)
  let usedSimps ← dischargeWrapper.with fun discharge? =>
    SciLean.Meta.CustomSimp.simpLocation ctx discharge? (expandOptLocation stx[5]) #[pre] #[post]
  if tactic.simp.trace.get (← getOptions) then
    dbg_trace "warning: Runnig custom simp with tracing, not sure if it is working properly!"
    traceSimpCall stx usedSimps

opaque foo : Nat → Nat
class Foo (n : Nat)

-- @[simp_guard n 0]
-- theorem foo_zero (n) [Foo n] : foo n = 0 := sorry

@[simp_guard f foo, a (0 : Nat)]
theorem foo_fun_zero {α : Type} [Foo n] (f : α → Nat) (a : α) : foo (f a) = 0 := sorry

set_option trace.Meta.Tactic.simp true in
set_option trace.Meta.Tactic.simp.unify true in
set_option trace.Meta.Tactic.simp.discharge true in
example (op : Nat → Nat → Nat) (a b c : Nat) :
  op (foo (foo a)) (foo $ op (foo (foo 0)) (foo $ op b c)) = 0 :=
by
  -- debug_simp [↓foo_zero]
  debug_simp [↓foo_fun_zero]
  admit


import Fine.FormalTheories
import Mathlib.Data.Prod.Lex
import Fine.Util.util

open Classical

def lindenbaumSequence (t : Th) (Δ : Ctx) : Lex (Nat × Nat) → Ctx
  | ⟨0, 0⟩ => t.val
  | ⟨i + 1, 0⟩ => { f : Form | ∃j : Nat, f ∈ lindenbaumSequence t Δ ⟨i, j⟩ }
  | ⟨i, j + 1⟩ =>
    let prev := lindenbaumSequence t Δ ⟨i, j⟩
    let l := (Denumerable.ofNat (Form × Form) j).fst
    let r := (Denumerable.ofNat (Form × Form) j).snd
    if l ¦ r ∈ ▲prev
    then if ▲(prev ∪ {l}) ∩ Δ = ∅
      then prev ∪ {l}
      else prev ∪ {r}
    else prev
  termination_by lindenbaumSequence _ _ p => (p.fst, p.snd)

lemma lindenbaumSequenceMonotone' { t : Th } { Δ : Ctx } : ∀b a, a ≤ b → lindenbaumSequence t Δ a ⊆ lindenbaumSequence t Δ b := by
  intros b
  match b with
    | ⟨0, 0⟩ =>
      intros a h₁
      cases h₁
      case left a₁ _ h₂ => exact False.elim $ Nat.not_lt_zero a₁ h₂
      case right b₁ h₂ =>
        rw [Nat.le_zero_eq b₁] at h₂
        rw [h₂]
    | ⟨i + 1, 0⟩ =>
      intros a h₁
      cases h₁
      case left a₁ b₁ h₂ =>
        have l₁ : a₁ < i ∨ a₁ = i := Nat.lt_or_eq_of_le $ Nat.lt_succ.mp h₂
        have l₂ : a₁ < i ∨ a₁ = i ∧ b₁ ≤ b₁ := by
          cases l₁
          case inl h₂ => exact Or.inl h₂
          case inr h₂ => exact Or.inr ⟨h₂, le_refl b₁⟩
        have l₃ := (Prod.Lex.le_iff (a₁, b₁) (i,b₁)).mpr l₂
        have l₄ := @lindenbaumSequenceMonotone' t Δ (i,b₁) (a₁, b₁) l₃
        apply le_trans l₄
        intros f h₂
        exact ⟨b₁,h₂⟩
      case right b₁ h₂ =>
        rw [Nat.le_zero_eq b₁] at h₂
        rw [h₂]
    | ⟨i, j + 1⟩ =>
      have lem : lindenbaumSequence t Δ (i, j) ≤ lindenbaumSequence t Δ (i, j + 1) := by
        intros f h₃
        unfold lindenbaumSequence
        split
        case h_1 _ heq | h_2 _ heq => injection heq; contradiction
        case h_3 i' j' heq =>
          injection heq with heq₁ heq₂
          injection heq₂ with heq₂
          have heq₃ : j = j' := heq₂
          rw [←heq₁, ←heq₃]
          change
            let prev := lindenbaumSequence t Δ (i, j);
            let l := (Denumerable.ofNat (Form × Form) j).fst;
            let r := (Denumerable.ofNat (Form × Form) j).snd;
            f ∈ if l¦r ∈ ▲prev then if ▲(prev ∪ {l}) ∩ Δ = ∅ then prev ∪ {l} else prev ∪ {r} else prev
          intros prev l r
          split
          case inl =>
            split
            case inl | inr => apply Or.inl h₃
          case inr => exact h₃
      intros a h₁
      cases h₁
      case left a₁ b₁ h₂ =>
          have l₁ : a₁ < i ∨ a₁ = i ∧ b₁ ≤ j := Or.inl h₂
          have l₂ := (Prod.Lex.le_iff (a₁, b₁) (i,j)).mpr l₁
          have l₃ := @lindenbaumSequenceMonotone' t Δ (i,j) (a₁, b₁)  l₂
          apply le_trans l₃
          exact lem
      case right b₁ h₂ =>
        cases h₂
        case refl => intros _ h₁; assumption
        case step h₂ =>
          have l₁ : i < i ∨ i = i ∧ b₁ ≤ j := Or.inr ⟨rfl, h₂⟩
          have l₂ := (Prod.Lex.le_iff (i, b₁) (i,j)).mpr l₁
          have l₃ := @lindenbaumSequenceMonotone' t Δ (i,j) (i, b₁)  l₂
          apply le_trans l₃
          exact lem

  termination_by lindenbaumSequenceMonotone' _ _ b => (b.fst, b.snd)

lemma lindenbaumSequenceMonotone { t : Th } { Δ : Ctx } : Monotone (lindenbaumSequence t Δ) := by
  intros a b
  exact lindenbaumSequenceMonotone' b a

def lindenbaumExtension (t : Th) (Δ : Ctx) : Ctx := {f | ∃ij : Nat × Nat, f ∈ lindenbaumSequence t Δ ij }

lemma lindenbaumStageMonotone { t : Th } { Δ : Ctx } { i : Nat } : Monotone (λj => lindenbaumSequence t Δ ⟨i,j⟩) := by
  intros a b h₁
  change lindenbaumSequence t Δ (i, a) ≤ lindenbaumSequence t Δ (i, b)
  have l₂ := (Prod.Lex.le_iff (i, a) (i,b)).mpr $ Or.inr ⟨rfl,h₁⟩
  exact lindenbaumSequenceMonotone' (i,b) (i,a) l₂

lemma lindenbaumExtensionExtends { t : Th } { Δ : Ctx } : t.val ⊆ lindenbaumExtension t Δ := by
  intros f h₁
  refine ⟨⟨0,0⟩,?_⟩
  assumption

theorem lindenbaumIsFormal { t : Th } { Δ : Ctx } : formalTheory (lindenbaumExtension t Δ) := by
  intros f
  apply Iff.intro
  case mp =>
    intro h₁
    exact ⟨BProof.ax h₁⟩
  case mpr =>
    intro h₁
    have ⟨prf₁⟩ := h₁
    have ⟨s, l₁, fprf⟩ := BProof.compactness prf₁
    have ⟨⟨i,j⟩,l₂⟩ := finiteExhaustion lindenbaumSequenceMonotone l₁
    have l₃ : lindenbaumSequence t Δ ⟨i,j⟩ ⊆ lindenbaumSequence t Δ ⟨i + 1,Encodable.encode (f,f)⟩ := by
      apply lindenbaumSequenceMonotone
      apply (Prod.Lex.le_iff (i,j) (i + 1,Encodable.encode (f,f))).mpr $ Or.inl $ Nat.lt_succ_self i
    have prf₂ := BProof.monotone (le_trans l₂ l₃) fprf
    have prf₃ : BProof (lindenbaumSequence t Δ ⟨i+1,Encodable.encode (f,f)⟩) (f ¦ f) := BProof.mp prf₂ BTheorem.orI₁
    clear s h₁ l₁ l₂ l₃ fprf prf₁ prf₂
    have l₄ : f ∈ lindenbaumSequence t Δ ⟨i + 1, Encodable.encode (f,f) + 1⟩ := by
      unfold lindenbaumSequence
      change
        let prev := lindenbaumSequence t Δ (i + 1, Encodable.encode (f,f));
        let l := (Denumerable.ofNat (Form × Form) (Encodable.encode (f,f))).fst;
        let r := (Denumerable.ofNat (Form × Form) (Encodable.encode (f,f))).snd;
        f ∈ if l¦r ∈ ▲prev then if ▲(prev ∪ {l}) ∩ Δ = ∅ then prev ∪ {l} else prev ∪ {r} else prev
      intros prev l r
      have l₅ : l = f := by
        change (Denumerable.ofNat (Form × Form) (Encodable.encode (f, f))).fst = f
        rw [Denumerable.ofNat_encode (f,f)]
      have l₆ : r = f := by
        change (Denumerable.ofNat (Form × Form) (Encodable.encode (f, f))).snd = f
        rw [Denumerable.ofNat_encode (f,f)]
      split
      case inl h₂ =>
        split
        . rw [l₅]; exact Or.inr rfl
        . rw [l₆]; exact Or.inr rfl
      case inr h₂ =>
        apply False.elim
        have l₇ : f¦f ∈ ▲prev := ⟨prf₃⟩
        rw [l₅,l₆] at h₂
        exact h₂ l₇
    exact ⟨⟨i + 1, Encodable.encode (f,f) + 1⟩, l₄⟩

theorem lindenbaumIsPrime { t : Th } { Δ : Ctx } : PrimeTheory (lindenbaumExtension t Δ) := by
  intros f g h₁
  have ⟨⟨i,j⟩,h₂⟩ := h₁
  let k := Encodable.encode (f,g)
  have l₁ : lindenbaumSequence t Δ ⟨i,j⟩ ⊆ lindenbaumSequence t Δ ⟨i + 1,k⟩ := by
    apply lindenbaumSequenceMonotone
    apply (Prod.Lex.le_iff (i,j) (i + 1,k)).mpr $ Or.inl $ Nat.lt_succ_self i
  have l₂ : f ¦ g ∈ lindenbaumSequence t Δ ⟨i + 1, k⟩ := l₁ h₂
  clear l₁ h₁ h₂
  have l₃ : f ∈ lindenbaumSequence t Δ ⟨i + 1, k + 1⟩ ∨ g ∈ lindenbaumSequence t Δ ⟨i + 1, k + 1⟩ := by
    unfold lindenbaumSequence
    change
      let prev := lindenbaumSequence t Δ (i + 1, k);
      let l := (Denumerable.ofNat (Form × Form) k).fst;
      let r := (Denumerable.ofNat (Form × Form) k).snd;
      (f ∈ if l¦r ∈ ▲prev then if ▲(prev ∪ {l}) ∩ Δ = ∅ then prev ∪ {l} else prev ∪ {r} else prev) ∨
      (g ∈ if l¦r ∈ ▲prev then if ▲(prev ∪ {l}) ∩ Δ = ∅ then prev ∪ {l} else prev ∪ {r} else prev)
    intros prev l r
    have l₄ : Denumerable.ofNat (Form × Form) k = (f,g) := Denumerable.ofNat_encode (f,g)
    have l₅ : l = f := by
      change (Denumerable.ofNat (Form × Form) k).fst = f
      rw [l₄]
    have l₆ : r = g := by
      change (Denumerable.ofNat (Form × Form) k).snd = g
      rw [l₄]
    repeat rw [l₅,l₆]
    clear l r l₅ l₆
    cases Classical.em (▲(prev ∪ {f}) ∩ Δ = ∅)
    case' inl h₁ => apply Or.inl
    case' inr h₁ => apply Or.inr
    all_goals
      split
      case inl => exact Or.inr rfl
      case inr h₂ => exact False.elim $ h₂ ⟨BProof.ax l₂⟩
  apply Or.elim l₃
  case left => intros h₁; exact Or.inl ⟨⟨i+1,k+1⟩,h₁⟩
  case right => intros h₁; exact Or.inr ⟨⟨i+1,k+1⟩,h₁⟩

theorem lindenbaumAvoids { t : Th } { Δ : Ctx } ( h₁ : ↑t ∩ Δ = ∅ ) ( h₂ : DisjunctionClosed Δ ) : ∀ij, ▲lindenbaumSequence t Δ ij ∩ Δ = ∅
  | ⟨0,0⟩ => by
    have l₁ := formalFixed t.property
    rw [←l₁] at h₁
    exact h₁
  | ⟨i + 1, 0⟩ => by
    change
      ▲{ f : Form | ∃j : Nat, f ∈ lindenbaumSequence t Δ ⟨i, j⟩ } ∩ Δ = ∅
    apply Set.not_nonempty_iff_eq_empty.mp
    intros h₃
    have ⟨w,⟨prf₁⟩,l₁⟩ := h₃
    clear h₃
    have ⟨s,l₂,prf₂⟩ := BProof.compactness prf₁
    have ⟨j, l₃⟩ := finiteExhaustion lindenbaumStageMonotone l₂
    have l₄ := lindenbaumAvoids h₁ h₂ ⟨i,j⟩
    have prf₃ := BProof.monotone l₃ prf₂
    have l₅ := Set.not_nonempty_iff_eq_empty.mpr l₄
    exact l₅ ⟨w, ⟨⟨prf₃⟩,l₁⟩⟩
  | ⟨i, j + 1⟩ => by
    apply Set.not_nonempty_iff_eq_empty.mp
    intros h₃
    have ⟨w₁,l₁,l₂⟩ := h₃
    unfold lindenbaumSequence at l₁
    split at l₁
    case h_1 x heq => injection heq with heq; contradiction
    case h_2 x heq => injection heq with heq; contradiction
    case h_3 x n m heq =>
      have l₃ := lindenbaumAvoids h₁ h₂ ⟨i,j⟩
      injection heq with heq₁ heq₂
      injection heq₂ with heq₂
      rw [←heq₁,←heq₂] at l₁
      clear n m x heq₁ heq₂ h₃
      dsimp at l₁ j
      split at l₁
      case inr h₄ => exact (Set.not_nonempty_iff_eq_empty.mpr l₃) ⟨w₁, l₁, l₂⟩
      case inl h₄ =>
        split at l₁
        case inl h₅ => exact (Set.not_nonempty_iff_eq_empty.mpr h₅) ⟨w₁, l₁, l₂⟩
        case inr h₅ =>
          have ⟨prf₁⟩ := l₁
          have ⟨w₂,⟨⟨prf₂⟩,l₄⟩⟩ := Set.nonempty_iff_ne_empty.mpr h₅
          have l₅ : w₁¦w₂ ∈ Δ := h₂ ⟨l₂, l₄⟩
          clear l₁ l₂ l₄ h₅
          have ⟨lst₁,l₆,prf₃⟩ := BProof.sentenceCompactness (Set.union_singleton ▸ prf₁)
          have ⟨lst₂,l₇,prf₄⟩ := BProof.sentenceCompactness (Set.union_singleton ▸ prf₂)
          have thm₁ := BTheorem.transitivity (BTheorem.fromProof prf₃) (BTheorem.orI₁ : BTheorem (w₁ ⊃ w₁ ¦ w₂))
          have thm₂ := BTheorem.transitivity (BTheorem.fromProof prf₄) (BTheorem.orI₂ : BTheorem (w₂ ⊃ w₁ ¦ w₂))
          have thm₃ := BTheorem.mp (BTheorem.adj thm₂ thm₁) BTheorem.orE
          have ⟨prf₅⟩ := h₄
          clear h₄ thm₁ thm₂ prf₁ prf₂ prf₃ prf₄
          cases lst₁
          all_goals
            cases lst₂
          case nil.nil =>
            have : w₁¦w₂ ∈ ▲lindenbaumSequence t Δ (i, j) ∩ Δ := ⟨⟨BProof.mp prf₅ thm₃⟩, l₅⟩
            exact (Set.not_nonempty_iff_eq_empty.mpr l₃) ⟨w₁¦w₂, this⟩
          -- could simplify these with a new BTheorem def
          case nil.cons head tail =>
            have := BProof.proveList l₇
            have := BProof.mp (BProof.adj prf₅ this) BTheorem.distRight
            have := BProof.mp this (BTheorem.mp
              (BTheorem.adj
                (BTheorem.transitivity BTheorem.taut BTheorem.orI₁)
                (BTheorem.transitivity BTheorem.andE₁ BTheorem.orI₂)
              ) BTheorem.orE)
            have : w₁¦w₂ ∈ ▲lindenbaumSequence t Δ (i, j) ∩ Δ := ⟨⟨BProof.mp this thm₃⟩, l₅⟩
            exact (Set.not_nonempty_iff_eq_empty.mpr l₃) ⟨w₁¦w₂, this⟩
          case cons.nil head tail =>
            have := BProof.proveList l₆
            have := BProof.mp (BProof.adj prf₅ this) BTheorem.distRight
            have := BProof.mp this (BTheorem.mp
              (BTheorem.adj
                (BTheorem.transitivity BTheorem.andE₁ BTheorem.orI₁)
                (BTheorem.transitivity BTheorem.taut BTheorem.orI₂)
              ) BTheorem.orE)
            have : w₁¦w₂ ∈ ▲lindenbaumSequence t Δ (i, j) ∩ Δ := ⟨⟨BProof.mp this thm₃⟩, l₅⟩
            exact (Set.not_nonempty_iff_eq_empty.mpr l₃) ⟨w₁¦w₂, this⟩
          case cons.cons head tail head' tail'=>
            have prf₆ := BProof.proveList l₆
            have prf₇ := BProof.proveList l₇
            have := BProof.mp (BProof.adj prf₅ prf₇) BTheorem.distRight
            have prf₈ := BProof.mp this (BTheorem.mp
              (BTheorem.adj
                (BTheorem.transitivity BTheorem.taut BTheorem.orI₁)
                (BTheorem.transitivity BTheorem.andE₁ BTheorem.orI₂)
              ) BTheorem.orE)
            have := BProof.mp (BProof.adj prf₈ prf₆) BTheorem.distRight
            have prf₉ := BProof.mp this (BTheorem.mp
              (BTheorem.adj
                (BTheorem.transitivity BTheorem.andE₁ BTheorem.orI₁)
                (BTheorem.transitivity BTheorem.taut BTheorem.orI₂)
              ) BTheorem.orE)
            have : w₁¦w₂ ∈ ▲lindenbaumSequence t Δ (i, j) ∩ Δ := ⟨⟨BProof.mp prf₉ thm₃⟩, l₅⟩
            exact (Set.not_nonempty_iff_eq_empty.mpr l₃) ⟨w₁¦w₂, this⟩

  termination_by lindenbaumAvoids _ _ _ _ p => (p.fst, p.snd)


import Runtime.Utilities

namespace Interface

/--
An interface scheme captures the type signature of a dependent map. Specifically, a scheme
`{ vars, type }` describes the type `(var : vars) → (type var)`.

This type is used to describe the structures of components in reactors like ports, state variables,
actions and parameters, which are all maps from names to values of different types.
-/
structure Scheme where
  vars : Type
  type : vars → Type
  [varsDecidableEq : DecidableEq vars]

attribute [reducible] Scheme.type
attribute [instance] Scheme.varsDecidableEq

/--
The (disjoint) union of two schemes describes the signature of a map where the domain is the
disjoint union of the respective schemes' domains. The codomain is extended in the obvious way.
-/
abbrev Scheme.union (σ₁ σ₂ : Scheme) : Scheme where
  vars := Sum σ₁.vars σ₂.vars
  type
    | .inl var => σ₁.type var
    | .inr var => σ₂.type var

infix:65 " ⊎ " => Scheme.union

@[simp]
theorem Scheme.union_type_left (σ₁ σ₂ : Scheme) (var : σ₁.vars) :
  (σ₁ ⊎ σ₂).type (.inl var) = σ₁.type var := rfl

@[simp]
theorem Scheme.union_type_right (σ₁ σ₂ : Scheme) (var : σ₂.vars) :
  (σ₁ ⊎ σ₂).type (.inr var) = σ₂.type var := rfl

/-- The big-union of schemes generalizes the notion of unions of schemes to a family of schemes. -/
def Scheme.bUnion (σs : I → Scheme) [DecidableEq I] : Scheme where
  vars := (i : I) × (σs i).vars
  type := fun ⟨i, var⟩ => (σs i).type var

prefix:100 " ⨄ " => Scheme.bUnion

@[simp]
theorem Scheme.bUnion_vars (σs : I → Scheme) [DecidableEq I] :
  (⨄ σs).vars = ((i : I) × (σs i).vars) := rfl

@[simp]
theorem Scheme.bUnion_type (σs : I → Scheme) [DecidableEq I] (var : (σs i).vars) :
  (⨄ σs).type ⟨i, var⟩ = (σs i).type var := rfl

/--
A scheme `σ₁` is a "subscheme" of `σ₂` if:
1. the domain of `σ₁` is a subtype of the domain of `σ₂`, and
2. `σ₁` and `σ₂` map the elements in `σ₁`'s domain to the same types.

We express property 1 not as a `Subtype` but as the coercion `coe`. Property 2 is ensured by
`coeEqType`. The `inv` map and additional properties provide an inverse map to `coe` (this map has
to be partial as `coe` isn't necessarilly bijective).
-/
class Subscheme (σ₁ σ₂ : Scheme) where
  coe       : σ₁.vars → σ₂.vars
  inv       : σ₂.vars → Option σ₁.vars
  invInj    : ∀ {a b₁ b₂}, (inv b₁ = some a) → (inv b₂ = some a) → (b₁ = b₂)
  coeInvId  : ∀ a, inv (coe a) = a
  coeEqType : ∀ {v}, σ₂.type (coe v) = σ₁.type v

theorem Subscheme.invEqType [inst : Subscheme σ₁ σ₂] : ∀ {b}, (inst.inv b = some a) → (σ₁.type a = σ₂.type b) :=
  fun h => by rw [←inst.coeEqType (v := a), inst.invInj h (inst.coeInvId a)]

end Interface

/--
An `Interface` over a scheme `{ vars, type }` is a map `(var : vars) → (type var)`. This type is
used to for components in reactors like state variables and parameters, which are maps from names to
values of different types.
-/
def Interface (σ : Interface.Scheme) := (var : σ.vars) → (σ.type var)

/--
An `Interface?` over a scheme `{ vars, type }` is a map `(var : vars) → Option (type var)`. This
type is used for components in reactors like ports and actions and parameters, which are maps from
names to values of different types which need to be able to be absent.
-/
def Interface? (σ : Interface.Scheme) := (var : σ.vars) → Option (σ.type var)

namespace Interface?

/-- The `Interface?` where every element is absent. -/
protected def empty : Interface? σ := fun _ => none

@[simp]
theorem empty_none : Interface?.empty var = none := rfl

/-- An `Interface?` is empty if it is `Interface?.empty` (that is, all elements are absent). -/
def isEmpty (i : Interface? σ) := i = Interface?.empty

@[simp]
theorem isEmpty_def (i : Interface? σ) : i.isEmpty ↔ i = Interface?.empty := by
  simp [isEmpty]

/-- An `Interface?` is empty if it is `Interface?.empty` (that is, all elements are absent). -/
def isPresent (i : Interface? σ) (var : σ.vars) : Bool :=
  i var |>.isSome

@[simp]
theorem isPresent_def (i : Interface? σ) : i.isPresent var ↔ ∃ v, i var = some v := by
  simp [isPresent, Option.isSome_iff_exists]

/--
Merges interface `i₂` "into" `i₁`. That is, for each element `e`:
* if `i₁ e` is present, return that value
* otherwise, return `i₂ e`
-/
def merge (i₁ i₂ : Interface? σ) : Interface? σ :=
  fun var => i₂ var |>.orElse fun _ => i₁ var

theorem merge_val₁ (i₁ i₂ : Interface? σ) : (i₂ var = none) → (i₁.merge i₂) var = i₁ var := by
  simp_all [merge, Option.orElse]

theorem merge_val₂ (i₁ i₂ : Interface? σ) : (i₂ var = some v) → (i₁.merge i₂) var = some v := by
  simp_all [merge, Option.orElse]

theorem merge_idem : Interface?.merge i i = i := by
  funext var
  simp [merge, Option.orElse]
  split
  · exact Eq.symm ‹_›
  · simp

/-- Restricts the domain of the given interface to that of a given subscheme. -/
def restrict [inst : Interface.Subscheme σ₁ σ₂] (i : Interface? σ₂) : Interface? σ₁ :=
  fun var => inst.coeEqType ▸ i (inst.coe var)

end Interface?


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

! This file was ported from Lean 3 source module group_theory.group_action.sum
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.GroupAction.Defs

/-!
# Sum instances for additive and multiplicative actions

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

This file defines instances for additive and multiplicative actions on the binary `sum` type.

## See also

* `group_theory.group_action.option`
* `group_theory.group_action.pi`
* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
-/

variable {M N P α β γ : Type _}

namespace Sum

section SMul

variable [SMul M α] [SMul M β] [SMul N α] [SMul N β] (a : M) (b : α) (c : β) (x : Sum α β)

@[to_additive Sum.hasVadd]
instance : SMul M (Sum α β) :=
  ⟨fun a => Sum.map ((· • ·) a) ((· • ·) a)⟩

/- warning: sum.smul_def -> Sum.smul_def is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} [_inst_1 : SMul.{u1, u2} M α] [_inst_2 : SMul.{u1, u3} M β] (a : M) (x : Sum.{u2, u3} α β), Eq.{succ (max u2 u3)} (Sum.{u2, u3} α β) (SMul.smul.{u1, max u2 u3} M (Sum.{u2, u3} α β) (Sum.hasSmul.{u1, u2, u3} M α β _inst_1 _inst_2) a x) (Sum.map.{u2, u3, u2, u3} α α β β (SMul.smul.{u1, u2} M α _inst_1 a) (SMul.smul.{u1, u3} M β _inst_2 a) x)
but is expected to have type
  forall {M : Type.{u1}} {α : Type.{u3}} {β : Type.{u2}} [_inst_1 : SMul.{u1, u3} M α] [_inst_2 : SMul.{u1, u2} M β] (a : M) (x : Sum.{u3, u2} α β), Eq.{max (succ u3) (succ u2)} (Sum.{u3, u2} α β) (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sum.{u3, u2} α β) (Sum.{u3, u2} α β) (instHSMul.{u1, max u3 u2} M (Sum.{u3, u2} α β) (Sum.instSMulSum.{u1, u3, u2} M α β _inst_1 _inst_2)) a x) (Sum.map.{u3, u2, u3, u2} α α β β ((fun (x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.199 : M) (x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.201 : α) => HSMul.hSMul.{u1, u3, u3} M α α (instHSMul.{u1, u3} M α _inst_1) x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.199 x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.201) a) ((fun (x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.218 : M) (x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.220 : β) => HSMul.hSMul.{u1, u2, u2} M β β (instHSMul.{u1, u2} M β _inst_2) x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.218 x._@.Mathlib.GroupTheory.GroupAction.Sum._hyg.220) a) x)
Case conversion may be inaccurate. Consider using '#align sum.smul_def Sum.smul_defₓ'. -/
@[to_additive]
theorem smul_def : a • x = x.map ((· • ·) a) ((· • ·) a) :=
  rfl
#align sum.smul_def Sum.smul_def
#align sum.vadd_def Sum.vadd_def

/- warning: sum.smul_inl -> Sum.smul_inl is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} [_inst_1 : SMul.{u1, u2} M α] [_inst_2 : SMul.{u1, u3} M β] (a : M) (b : α), Eq.{succ (max u2 u3)} (Sum.{u2, u3} α β) (SMul.smul.{u1, max u2 u3} M (Sum.{u2, u3} α β) (Sum.hasSmul.{u1, u2, u3} M α β _inst_1 _inst_2) a (Sum.inl.{u2, u3} α β b)) (Sum.inl.{u2, u3} α β (SMul.smul.{u1, u2} M α _inst_1 a b))
but is expected to have type
  forall {M : Type.{u1}} {α : Type.{u3}} {β : Type.{u2}} [_inst_1 : SMul.{u1, u3} M α] [_inst_2 : SMul.{u1, u2} M β] (a : M) (b : α), Eq.{max (succ u3) (succ u2)} (Sum.{u3, u2} α β) (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sum.{u3, u2} α β) (Sum.{u3, u2} α β) (instHSMul.{u1, max u3 u2} M (Sum.{u3, u2} α β) (Sum.instSMulSum.{u1, u3, u2} M α β _inst_1 _inst_2)) a (Sum.inl.{u3, u2} α β b)) (Sum.inl.{u3, u2} α β (HSMul.hSMul.{u1, u3, u3} M α α (instHSMul.{u1, u3} M α _inst_1) a b))
Case conversion may be inaccurate. Consider using '#align sum.smul_inl Sum.smul_inlₓ'. -/
@[simp, to_additive]
theorem smul_inl : a • (inl b : Sum α β) = inl (a • b) :=
  rfl
#align sum.smul_inl Sum.smul_inl
#align sum.vadd_inl Sum.vadd_inl

/- warning: sum.smul_inr -> Sum.smul_inr is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} [_inst_1 : SMul.{u1, u2} M α] [_inst_2 : SMul.{u1, u3} M β] (a : M) (c : β), Eq.{succ (max u2 u3)} (Sum.{u2, u3} α β) (SMul.smul.{u1, max u2 u3} M (Sum.{u2, u3} α β) (Sum.hasSmul.{u1, u2, u3} M α β _inst_1 _inst_2) a (Sum.inr.{u2, u3} α β c)) (Sum.inr.{u2, u3} α β (SMul.smul.{u1, u3} M β _inst_2 a c))
but is expected to have type
  forall {M : Type.{u1}} {α : Type.{u3}} {β : Type.{u2}} [_inst_1 : SMul.{u1, u3} M α] [_inst_2 : SMul.{u1, u2} M β] (a : M) (c : β), Eq.{max (succ u3) (succ u2)} (Sum.{u3, u2} α β) (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sum.{u3, u2} α β) (Sum.{u3, u2} α β) (instHSMul.{u1, max u3 u2} M (Sum.{u3, u2} α β) (Sum.instSMulSum.{u1, u3, u2} M α β _inst_1 _inst_2)) a (Sum.inr.{u3, u2} α β c)) (Sum.inr.{u3, u2} α β (HSMul.hSMul.{u1, u2, u2} M β β (instHSMul.{u1, u2} M β _inst_2) a c))
Case conversion may be inaccurate. Consider using '#align sum.smul_inr Sum.smul_inrₓ'. -/
@[simp, to_additive]
theorem smul_inr : a • (inr c : Sum α β) = inr (a • c) :=
  rfl
#align sum.smul_inr Sum.smul_inr
#align sum.vadd_inr Sum.vadd_inr

/- warning: sum.smul_swap -> Sum.smul_swap is a dubious translation:
lean 3 declaration is
  forall {M : Type.{u1}} {α : Type.{u2}} {β : Type.{u3}} [_inst_1 : SMul.{u1, u2} M α] [_inst_2 : SMul.{u1, u3} M β] (a : M) (x : Sum.{u2, u3} α β), Eq.{max (succ u3) (succ u2)} (Sum.{u3, u2} β α) (Sum.swap.{u2, u3} α β (SMul.smul.{u1, max u2 u3} M (Sum.{u2, u3} α β) (Sum.hasSmul.{u1, u2, u3} M α β _inst_1 _inst_2) a x)) (SMul.smul.{u1, max u3 u2} M (Sum.{u3, u2} β α) (Sum.hasSmul.{u1, u3, u2} M β α _inst_2 _inst_1) a (Sum.swap.{u2, u3} α β x))
but is expected to have type
  forall {M : Type.{u1}} {α : Type.{u3}} {β : Type.{u2}} [_inst_1 : SMul.{u1, u3} M α] [_inst_2 : SMul.{u1, u2} M β] (a : M) (x : Sum.{u3, u2} α β), Eq.{max (succ u3) (succ u2)} (Sum.{u2, u3} β α) (Sum.swap.{u3, u2} α β (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sum.{u3, u2} α β) (Sum.{u3, u2} α β) (instHSMul.{u1, max u3 u2} M (Sum.{u3, u2} α β) (Sum.instSMulSum.{u1, u3, u2} M α β _inst_1 _inst_2)) a x)) (HSMul.hSMul.{u1, max u3 u2, max u3 u2} M (Sum.{u2, u3} β α) (Sum.{u2, u3} β α) (instHSMul.{u1, max u3 u2} M (Sum.{u2, u3} β α) (Sum.instSMulSum.{u1, u2, u3} M β α _inst_2 _inst_1)) a (Sum.swap.{u3, u2} α β x))
Case conversion may be inaccurate. Consider using '#align sum.smul_swap Sum.smul_swapₓ'. -/
@[simp, to_additive]
theorem smul_swap : (a • x).symm = a • x.symm := by cases x <;> rfl
#align sum.smul_swap Sum.smul_swap
#align sum.vadd_swap Sum.vadd_swap

instance [SMul M N] [IsScalarTower M N α] [IsScalarTower M N β] : IsScalarTower M N (Sum α β) :=
  ⟨fun a b x => by
    cases x
    exacts[congr_arg inl (smul_assoc _ _ _), congr_arg inr (smul_assoc _ _ _)]⟩

@[to_additive]
instance [SMulCommClass M N α] [SMulCommClass M N β] : SMulCommClass M N (Sum α β) :=
  ⟨fun a b x => by
    cases x
    exacts[congr_arg inl (smul_comm _ _ _), congr_arg inr (smul_comm _ _ _)]⟩

@[to_additive]
instance [SMul Mᵐᵒᵖ α] [SMul Mᵐᵒᵖ β] [IsCentralScalar M α] [IsCentralScalar M β] :
    IsCentralScalar M (Sum α β) :=
  ⟨fun a x => by
    cases x
    exacts[congr_arg inl (op_smul_eq_smul _ _), congr_arg inr (op_smul_eq_smul _ _)]⟩

#print Sum.FaithfulSMulLeft /-
@[to_additive]
instance FaithfulSMulLeft [FaithfulSMul M α] : FaithfulSMul M (Sum α β) :=
  ⟨fun x y h => eq_of_smul_eq_smul fun a : α => by injection h (inl a)⟩
#align sum.has_faithful_smul_left Sum.FaithfulSMulLeft
#align sum.has_faithful_vadd_left Sum.FaithfulVAddLeft
-/

#print Sum.FaithfulSMulRight /-
@[to_additive]
instance FaithfulSMulRight [FaithfulSMul M β] : FaithfulSMul M (Sum α β) :=
  ⟨fun x y h => eq_of_smul_eq_smul fun b : β => by injection h (inr b)⟩
#align sum.has_faithful_smul_right Sum.FaithfulSMulRight
#align sum.has_faithful_vadd_right Sum.FaithfulVAddRight
-/

end SMul

@[to_additive]
instance {m : Monoid M} [MulAction M α] [MulAction M β] : MulAction M (Sum α β)
    where
  mul_smul a b x := by
    cases x
    exacts[congr_arg inl (mul_smul _ _ _), congr_arg inr (mul_smul _ _ _)]
  one_smul x := by
    cases x
    exacts[congr_arg inl (one_smul _ _), congr_arg inr (one_smul _ _)]

end Sum


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/
import tactic.core

/-!
# The `unify_equations` tactic

This module defines `unify_equations`, a first-order unification tactic that
unifies one or more equations in the context. It implements the Qnify algorithm
from [McBride, Inverting Inductively Defined Relations in LEGO][mcbride1996].

The tactic takes as input some equations which it simplifies one after the
other. Each equation is simplified by applying one of several possible
unification steps. Each such step may output other (simpler) equations which are
unified recursively until no unification step applies any more. See
`tactic.interactive.unify_equations` for an example and an explanation of the
different steps.
-/

open expr

namespace tactic
namespace unify_equations

/--
The result of a unification step:

- `simplified hs` means that the step succeeded and produced some new (simpler)
  equations `hs`. `hs` can be empty.
- `goal_solved` means that the step succeeded and solved the goal (by deriving a
  contradiction from the given equation).
- `not_simplified` means that the step failed to simplify the equation.
-/
meta inductive unification_step_result : Type
| simplified (next_equations : list name)
| not_simplified
| goal_solved

export unification_step_result

/--
A unification step is a tactic that attempts to simplify a given equation and
returns a `unification_step_result`. The inputs are:

- `equ`, the equation being processed. Must be a local constant.
- `lhs_type` and `rhs_type`, the types of equ's LHS and RHS. For homogeneous
  equations, these are defeq.
- `lhs` and `rhs`, `equ`'s LHS and RHS.
- `lhs_whnf` and `rhs_whnf`, `equ`'s LHS and RHS in WHNF.
- `u`, `equ`'s level.

So `equ : @eq.{u} lhs_type lhs rhs` or `equ : @heq.{u} lhs_type lhs rhs_type rhs`.
-/
@[reducible] meta def unification_step : Type :=
∀ (equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf : expr) (u : level),
  tactic unification_step_result

/--
For `equ : t == u` with `t : T` and `u : U`, if `T` and `U` are defeq,
we replace `equ` with `equ : t = u`.
-/
meta def unify_heterogeneous : unification_step :=
λ equ lhs_type rhs_type lhs rhs _ _ _,
do
{ is_def_eq lhs_type rhs_type,
  p ← to_expr ``(@eq_of_heq %%lhs_type %%lhs %%rhs %%equ),
  t ← to_expr ``(@eq %%lhs_type %%lhs %%rhs),
  equ' ← note equ.local_pp_name t p,
  clear equ,
  pure $ simplified [equ'.local_pp_name] } <|>
pure not_simplified

/--
For `equ : t = u`, if `t` and `u` are defeq, we delete `equ`.
-/
meta def unify_defeq : unification_step :=
λ equ lhs_type _ _ _ lhs_whnf rhs_whnf _,
do
{ is_def_eq lhs_whnf rhs_whnf,
  clear equ,
  pure $ simplified [] } <|>
pure not_simplified

/--
For `equ : x = t` or `equ : t = x`, where `x` is a local constant, we
substitute `x` with `t` in the goal.
-/
meta def unify_var : unification_step :=
λ equ type _ lhs rhs lhs_whnf rhs_whnf u,
do
{ let lhs_is_local := lhs_whnf.is_local_constant,
  let rhs_is_local := rhs_whnf.is_local_constant,
  guard $ lhs_is_local ∨ rhs_is_local,
  let t :=
    if lhs_is_local
      then (const `eq [u]) type lhs_whnf rhs
      else (const `eq [u]) type lhs rhs_whnf,
  change_core t (some equ),
  equ ← get_local equ.local_pp_name,
  subst_core equ,
  pure $ simplified [] } <|>
pure not_simplified

-- TODO This is an improved version of `injection_with` from core
-- (init/meta/injection_tactic). Remove when the improvements have landed in
-- core.
private meta def injection_with' (h : expr) (ns : list name)
  (base := `h) (offset := some 1) :
  tactic (option (list expr) × list name) :=
do
  H ← infer_type h,
  (lhs, rhs, constructor_left, constructor_right, inj_name) ← do
  { (lhs, rhs) ← match_eq H,
    constructor_left ← get_app_fn_const_whnf lhs semireducible ff,
    constructor_right ← get_app_fn_const_whnf rhs semireducible ff,
    inj_name ← resolve_constant $ constructor_left ++ "inj_arrow",
    pure (lhs, rhs, constructor_left, constructor_right, inj_name) }
  <|> fail
    ("injection tactic failed, argument must be an equality proof where lhs and rhs " ++
    "are of the form (c ...), where c is a constructor"),
  if constructor_left = constructor_right then do
    -- C.inj_arrow, for a given constructor C of datatype D, has type
    --
    --     ∀ (A₁ ... Aₙ) (x₁ ... xₘ) (y₁ ... yₘ), C x₁ ... xₘ = C y₁ ... yₘ
    --       → ∀ ⦃P : Sort u⦄, (x₁ = y₁ → ... → yₖ = yₖ → P) → P
    --
    -- where the Aᵢ are parameters of D and the xᵢ/yᵢ are arguments of C.
    -- Note that if xᵢ/yᵢ are propositions, no equation is generated, so the
    -- number of equations is not necessarily the constructor arity.

    -- First, we find out how many equations we need to intro later.
    inj ← mk_const inj_name,
    inj_type ← infer_type inj,
    inj_arity ← get_pi_arity inj_type,
    let num_equations :=
      (inj_type.nth_binding_body (inj_arity - 1)).binding_domain.pi_arity,

    -- Now we generate the actual proof of the target.
    tgt ← target,
    proof ← mk_mapp inj_name (list.replicate (inj_arity - 3) none ++ [some h, some tgt]),
    eapply proof,
    (next, ns) ← intron_with num_equations ns base offset,

    -- The following filters out 'next' hypotheses of type `true`. The
    -- `inj_arrow` lemmas introduce these for nullary constructors.
    next ← next.mfilter $ λ h, do
    { `(true) ← infer_type h | pure tt,
      (clear h >> pure ff) <|> pure tt },
    pure (some next, ns)
  else do
    tgt ← target,
    -- The following construction deals with a corner case involing
    -- mutual/nested inductive types. For these, Lean does not generate
    -- no-confusion principles. However, the regular inductive data type which a
    -- mutual/nested inductive type is compiled to does have a no-confusion
    -- principle which we can (usually? always?) use. To find it, we normalise
    -- the constructor with `unfold_ginductive = tt`.
    constructor_left ← get_app_fn_const_whnf lhs semireducible tt,
    let no_confusion := constructor_left.get_prefix ++ "no_confusion",
    pr ← mk_app no_confusion [tgt, lhs, rhs, h],
    exact pr,
    return (none, ns)

/--
Given `equ : C x₁ ... xₙ = D y₁ ... yₘ` with `C` and `D` constructors of the
same datatype `I`:

- If `C ≠ D`, we solve the goal by contradiction using the no-confusion rule.
- If `C = D`, we clear `equ` and add equations `x₁ = y₁`, ..., `xₙ = yₙ`.
-/
meta def unify_constructor_headed : unification_step :=
λ equ _ _ _ _ _ _ _,
do
{ (next, _) ← injection_with' equ [] `_ none,
  try $ clear equ,
  pure $
    match next with
    | none := goal_solved
    | some next := simplified $ next.map expr.local_pp_name
    end } <|>
pure not_simplified

/--
For `type = I x₁ ... xₙ`, where `I` is an inductive type, `get_sizeof type`
returns the constant `I.sizeof`. Fails if `type` is not of this form or if no
such constant exists.
-/
meta def get_sizeof (type : expr) : tactic pexpr := do
  n ← get_app_fn_const_whnf type semireducible ff,
  resolve_name $ n ++ `sizeof

lemma add_add_one_ne (n m : ℕ) : n + (m + 1) ≠ n :=
begin
  apply ne_of_gt,
  apply nat.lt_add_of_pos_right,
  apply nat.pos_of_ne_zero,
  contradiction
end
-- Linarith could prove this, but I want to avoid that dependency.

/--
`match_n_plus_m n e` matches `e` of the form `nat.succ (... (nat.succ e')...)`.
It returns `n` plus the number of `succ` constructors and `e'`. The matching is
performed up to normalisation with transparency `md`.
-/
meta def match_n_plus_m (md) : ℕ → expr → tactic (ℕ × expr) :=
λ n e, do
  e ← whnf e md,
  match e with
  | `(nat.succ %%e) := match_n_plus_m (n + 1) e
  | _ := pure (n, e)
  end

/--
Given `equ : n + m = n` or `equ : n = n + m` with `n` and `m` natural numbers
and `m` a nonzero literal, this tactic produces a proof of `false`. More
precisely, the two sides of the equation must be of the form
`nat.succ (... (nat.succ e)...)` with different numbers of `nat.succ`
constructors. Matching is performed with transparency `md`.
-/
meta def contradict_n_eq_n_plus_m (md : transparency) (equ lhs rhs : expr) :
  tactic expr := do
  ⟨lhs_n, lhs_e⟩ ← match_n_plus_m md 0 lhs,
  ⟨rhs_n, rhs_e⟩ ← match_n_plus_m md 0 rhs,
  is_def_eq lhs_e rhs_e md <|> fail
    ("contradict_n_eq_n_plus_m:\nexpected {lhs_e} and {rhs_e} to be definitionally " ++
    "equal at transparency {md}."),
  let common := lhs_e,
  guard (lhs_n ≠ rhs_n) <|> fail
    "contradict_n_eq_n_plus_m:\nexpected {lhs_n} and {rhs_n} to be different.",
  -- Ensure that lhs_n is bigger than rhs_n. Swap lhs and rhs if that's not
  -- already the case.
  ⟨equ, lhs_n, rhs_n⟩ ←
    if lhs_n > rhs_n
      then pure (equ, lhs_n, rhs_n)
      else do
      { equ ← to_expr ``(eq.symm %%equ),
        pure (equ, rhs_n, lhs_n) },
  let diff := lhs_n - rhs_n,
  let rhs_n_expr := reflect rhs_n,
  n ← to_expr ``(%%common + %%rhs_n_expr),
  let m := reflect (diff - 1),
  pure `(add_add_one_ne %%n %%m %%equ)

/--
Given `equ : t = u` with `t, u : I` and `I.sizeof t ≠ I.sizeof u`, we solve the
goal by contradiction.
-/
meta def unify_cyclic : unification_step :=
λ equ type _ _ _ lhs_whnf rhs_whnf _,
do
{ -- Establish `sizeof lhs = sizeof rhs`.
  sizeof ← get_sizeof type,
  hyp_lhs ← to_expr ``(%%sizeof %%lhs_whnf),
  hyp_rhs ← to_expr ``(%%sizeof %%rhs_whnf),
  hyp_type ← to_expr ``(@eq ℕ %%hyp_lhs %%hyp_rhs),
  hyp_proof ← to_expr ``(@congr_arg %%type ℕ %%lhs_whnf %%rhs_whnf %%sizeof %%equ),
  hyp_name ← mk_fresh_name,
  hyp ← note hyp_name hyp_type hyp_proof,

  -- Derive a contradiction (if indeed `sizeof lhs ≠ sizeof rhs`).
  falso ← contradict_n_eq_n_plus_m semireducible hyp hyp_lhs hyp_rhs,
  exfalso,
  exact falso,
  pure goal_solved } <|>
pure not_simplified

/--
`orelse_step s t` first runs the unification step `s`. If this was successful
(i.e. `s` simplified or solved the goal), it returns the result of `s`.
Otherwise, it runs `t` and returns its result.
-/
meta def orelse_step (s t : unification_step) : unification_step :=
λ equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u,
do
  r ← s equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u,
  match r with
  | simplified _ := pure r
  | goal_solved := pure r
  | not_simplified := t equ lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u
  end

/--
For `equ : t = u`, try the following methods in order: `unify_defeq`,
`unify_var`, `unify_constructor_headed`, `unify_cyclic`. If any of them is
successful, stop and return its result. If none is successful, fail.
-/
meta def unify_homogeneous : unification_step :=
list.foldl orelse_step (λ _ _ _ _ _ _ _ _, pure not_simplified)
  [unify_defeq, unify_var, unify_constructor_headed, unify_cyclic]

end unify_equations

open unify_equations

/--
If `equ` is the display name of a local constant with type `t = u` or `t == u`,
then `unify_equation_once equ` simplifies it once using
`unify_equations.unify_homogeneous` or `unify_equations.unify_heterogeneous`.

Otherwise it fails.
-/
meta def unify_equation_once (equ : name) : tactic unification_step_result := do
  eque ← get_local equ,
  t ← infer_type eque,
  match t with
  | (app (app (app (const `eq [u]) type) lhs) rhs) := do
    lhs_whnf ← whnf_ginductive lhs,
    rhs_whnf ← whnf_ginductive rhs,
    unify_homogeneous eque type type lhs rhs lhs_whnf rhs_whnf u
  | (app (app (app (app (const `heq [u]) lhs_type) lhs) rhs_type) rhs) := do
    lhs_whnf ← whnf_ginductive lhs,
    rhs_whnf ← whnf_ginductive rhs,
    unify_heterogeneous eque lhs_type rhs_type lhs rhs lhs_whnf rhs_whnf u
  | _ := fail! "Expected {equ} to be an equation, but its type is\n{t}."
  end

/--
Given a list of display names of local hypotheses that are (homogeneous or
heterogeneous) equations, `unify_equations` performs first-order unification on
each hypothesis in order. See `tactic.interactive.unify_equations` for an
example and an explanation of what unification does.

Returns true iff the goal has been solved during the unification process.

Note: you must make sure that the input names are unique in the context.
-/
meta def unify_equations : list name → tactic bool
| [] := pure ff
| (h :: hs) := do
  res ← unify_equation_once h,
  match res with
  | simplified hs' := unify_equations $ hs' ++ hs
  | not_simplified := unify_equations hs
  | goal_solved := pure tt
  end

namespace interactive

open lean.parser

/--
`unify_equations eq₁ ... eqₙ` performs a form of first-order unification on the
hypotheses `eqᵢ`. The `eqᵢ` must be homogeneous or heterogeneous equations.
Unification means that the equations are simplified using various facts about
constructors. For instance, consider this goal:

```
P : ∀ n, fin n → Prop
n m : ℕ
f : fin n
g : fin m
h₁ : n + 1 = m + 1
h₂ : f == g
h₃ : P n f
⊢ P m g
```

After `unify_equations h₁ h₂`, we get

```
P : ∀ n, fin n → Prop
n : ℕ
f : fin n
h₃ : P n f
⊢ P n f
```

In the example, `unify_equations` uses the fact that every constructor is
injective to conclude `n = m` from `h₁`. Then it replaces every `m` with `n` and
moves on to `h₂`. The types of `f` and `g` are now equal, so the heterogeneous
equation turns into a homogeneous one and `g` is replaced by `f`. Note that the
equations are processed from left to right, so `unify_equations h₂ h₁` would not
simplify as much.

In general, `unify_equations` uses the following steps on each equation until
none of them applies any more:

- Constructor injectivity: if `nat.succ n = nat.succ m` then `n = m`.
- Substitution: if `x = e` for some hypothesis `x`, then `x` is replaced by `e`
  everywhere.
- No-confusion: `nat.succ n = nat.zero` is a contradiction. If we have such an
  equation, the goal is solved immediately.
- Cycle elimination: `n = nat.succ n` is a contradiction.
- Redundancy: if `t = u` but `t` and `u` are already definitionally equal, then
  this equation is removed.
- Downgrading of heterogeneous equations: if `t == u` but `t` and `u` have the
  same type (up to definitional equality), then the equation is replaced by
  `t = u`.
-/
meta def unify_equations (eqs : interactive.parse (many ident)) :
  tactic unit :=
tactic.unify_equations eqs *> skip

add_tactic_doc
{ name := "unify_equations",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.unify_equations],
  tags := ["simplification"] }

end interactive
end tactic


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

Instances for identity and composition functors
-/

import category.functor

universe variables u v w

section lemmas

open function

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

attribute [functor_norm] seq_assoc pure_seq_eq_map map_pure seq_map_assoc map_seq

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
  have : @p1 = @p2, {funext α x, apply H1}, subst this,
  have : @s1 = @s2, {funext α β f x, apply H2}, subst this,
  cases L1, cases L2,
  have : F1 = F2,
  { resetI, apply functor.ext, intros,
    exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _) },
  subst this,
  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 comp

open function (hiding comp)
open functor

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

variables [applicative F] [applicative G]

protected def seq {α β : Type v} : comp F G (α → β) → comp F G α → comp F G β
| (comp.mk f) (comp.mk x) := comp.mk $ (<*>) <$> f <*> x

instance : has_pure (comp F G) :=
⟨λ _ x, comp.mk $ pure $ pure x⟩

instance : has_seq (comp F G) :=
⟨λ _ _ f x, comp.seq f x⟩

@[simp] protected lemma run_pure {α : Type v} :
  ∀ x : α, (pure x : comp F G α).run = pure (pure x)
| _ := rfl

@[simp] protected lemma run_seq {α β : Type v} (f : comp F G (α → β)) (x : comp F G α) :
  (f <*> x).run = (<*>) <$> f.run <*> x.run := rfl

instance : applicative (comp F G) :=
{ map := @comp.map F G _ _,
  seq := @comp.seq F G _ _,
  ..comp.has_pure }

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 seq_assoc (x : comp F G α) (f : comp F G (α → β)) (g : comp F G (β → γ)) :
   g <*> (f <*> x) = (@function.comp α β γ <$> g) <*> f <*> x :=
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
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


import pseudo_normed_group.CLC
import rescale.LC

open_locale classical nnreal
open opposite ProFiltPseuNormGrpWithTinv

open SemiNormedGroup opposite Profinite pseudo_normed_group category_theory breen_deligne
open profinitely_filtered_pseudo_normed_group

universe variable u
variables (r : ℝ≥0) (V : SemiNormedGroup) (r' : ℝ≥0) [fact (0 < r')]
variables (c c₁ c₂ c₃ c₄ : ℝ≥0) (m n : ℕ)

@[simp] theorem CLCFP_rescale (N : ℝ≥0)
  (M) [profinitely_filtered_pseudo_normed_group_with_Tinv r' M] :
  (CLCFP V r' c n).obj (op (of r' (rescale N M))) =
  (CLCFP V r' (c * N⁻¹) n).obj (op (of r' M)) := rfl

namespace breen_deligne

namespace universal_map

variables (ϕ : universal_map m n)

theorem eval_CLCFP_rescale [ϕ.suitable c₂ c₁]
  (N : ℝ≥0)
  (M : ProFiltPseuNormGrpWithTinv r') :
  arrow.mk ((eval_CLCFP V r' c₁ c₂ ϕ).app (op (of r' (rescale N M)))) =
  arrow.mk ((eval_CLCFP V r' (c₁ * N⁻¹) (c₂ * N⁻¹) ϕ).app (op M)) :=
by { dsimp only [eval_CLCFP, whisker_right_app], rw eval_LCFP_rescale, cases M, refl }

end universal_map

end breen_deligne


import tactic.tauto
import tactic.split_ifs

@[simp] lemma sum_inl_eq_ite {α β : Type*} (c : Prop) [decidable c] (x z : α) (y : β) :
  (sum.inl z = if c then sum.inl x else sum.inr y) ↔ c ∧ z = x := by split_ifs; simp; tauto

@[simp] lemma sum_inl_eq_ite_symm {α β : Type*} (c : Prop) [decidable c] (x z : α) (y : β) :
  ((if c then sum.inl x else sum.inr y) = sum.inl z) ↔ c ∧ z = x := by split_ifs; tauto

@[simp] lemma sum_inr_eq_ite {α β : Type*} (c : Prop) [decidable c] (x : α) (y z : β) :
  (sum.inr z = if c then sum.inl x else sum.inr y) ↔ ¬c ∧ z = y := by split_ifs; simp; tauto

@[simp] lemma sum_inr_eq_ite_symm {α β : Type*} (c : Prop) [decidable c] (x : α) (y z : β) :
  ((if c then sum.inl x else sum.inr y) = sum.inr z) ↔ ¬c ∧ z = y := by split_ifs; tauto


/-
Copyright (c) 2018 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.uniform_space.abstract_completion
import Mathlib.PostPort

universes u v u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Hausdorff completions of uniform spaces

The goal is to construct a left-adjoint to the inclusion of complete Hausdorff uniform spaces
into all uniform spaces. Any uniform space `α` gets a completion `completion α` and a morphism
(ie. uniformly continuous map) `coe : α → completion α` which solves the universal
mapping problem of factorizing morphisms from `α` to any complete Hausdorff uniform space `β`.
It means any uniformly continuous `f : α → β` gives rise to a unique morphism
`completion.extension f : completion α → β` such that `f = completion.extension f ∘ coe`.
Actually `completion.extension f` is defined for all maps from `α` to `β` but it has the desired
properties only if `f` is uniformly continuous.

Beware that `coe` is not injective if `α` is not Hausdorff. But its image is always
dense. The adjoint functor acting on morphisms is then constructed by the usual abstract nonsense.
For every uniform spaces `α` and `β`, it turns `f : α → β` into a morphism
  `completion.map f : completion α → completion β`
such that
  `coe ∘ f = (completion.map f) ∘ coe`
provided `f` is uniformly continuous. This construction is compatible with composition.

In this file we introduce the following concepts:

* `Cauchy α` the uniform completion of the uniform space `α` (using Cauchy filters). These are not
  minimal filters.

* `completion α := quotient (separation_setoid (Cauchy α))` the Hausdorff completion.

## References

This formalization is mostly based on
  N. Bourbaki: General Topology
  I. M. James: Topologies and Uniformities
From a slightly different perspective in order to reuse material in topology.uniform_space.basic.
-/

/-- Space of Cauchy filters

This is essentially the completion of a uniform space. The embeddings are the neighbourhood filters.
This space is not minimal, the separated uniform space (i.e. quotiented on the intersection of all
entourages) is necessary for this.
-/
def Cauchy (α : Type u) [uniform_space α] := Subtype fun (f : filter α) => cauchy f

namespace Cauchy

def gen {α : Type u} [uniform_space α] (s : set (α × α)) : set (Cauchy α × Cauchy α) :=
  set_of
    fun (p : Cauchy α × Cauchy α) =>
      s ∈ filter.prod (subtype.val (prod.fst p)) (subtype.val (prod.snd p))

theorem monotone_gen {α : Type u} [uniform_space α] : monotone gen :=
  set.monotone_set_of fun (p : Cauchy α × Cauchy α) => filter.monotone_mem_sets

protected instance uniform_space {α : Type u} [uniform_space α] : uniform_space (Cauchy α) :=
  uniform_space.of_core
    (uniform_space.core.mk (filter.lift' (uniformity α) gen) sorry symm_gen comp_gen)

theorem mem_uniformity {α : Type u} [uniform_space α] {s : set (Cauchy α × Cauchy α)} :
    s ∈ uniformity (Cauchy α) ↔ ∃ (t : set (α × α)), ∃ (H : t ∈ uniformity α), gen t ⊆ s :=
  filter.mem_lift'_sets monotone_gen

theorem mem_uniformity' {α : Type u} [uniform_space α] {s : set (Cauchy α × Cauchy α)} :
    s ∈ uniformity (Cauchy α) ↔
        ∃ (t : set (α × α)),
          ∃ (H : t ∈ uniformity α),
            ∀ (f g : Cauchy α), t ∈ filter.prod (subtype.val f) (subtype.val g) → (f, g) ∈ s :=
  iff.trans mem_uniformity (bex_congr fun (t : set (α × α)) (h : t ∈ uniformity α) => prod.forall)

/-- Embedding of `α` into its completion `Cauchy α` -/
def pure_cauchy {α : Type u} [uniform_space α] (a : α) : Cauchy α :=
  { val := pure a, property := cauchy_pure }

theorem uniform_inducing_pure_cauchy {α : Type u} [uniform_space α] :
    uniform_inducing pure_cauchy :=
  sorry

theorem uniform_embedding_pure_cauchy {α : Type u} [uniform_space α] :
    uniform_embedding pure_cauchy :=
  uniform_embedding.mk
    (uniform_inducing.mk (uniform_inducing.comap_uniformity uniform_inducing_pure_cauchy))
    fun (a₁ a₂ : α) (h : pure_cauchy a₁ = pure_cauchy a₂) =>
      filter.pure_injective (iff.mp subtype.ext_iff_val h)

theorem dense_range_pure_cauchy {α : Type u} [uniform_space α] : dense_range pure_cauchy := sorry

theorem dense_inducing_pure_cauchy {α : Type u} [uniform_space α] : dense_inducing pure_cauchy :=
  uniform_inducing.dense_inducing uniform_inducing_pure_cauchy dense_range_pure_cauchy

theorem dense_embedding_pure_cauchy {α : Type u} [uniform_space α] : dense_embedding pure_cauchy :=
  uniform_embedding.dense_embedding uniform_embedding_pure_cauchy dense_range_pure_cauchy

theorem nonempty_Cauchy_iff {α : Type u} [uniform_space α] : Nonempty (Cauchy α) ↔ Nonempty α :=
  sorry

protected instance complete_space {α : Type u} [uniform_space α] : complete_space (Cauchy α) :=
  complete_space_extension uniform_inducing_pure_cauchy dense_range_pure_cauchy
    fun (f : filter α) (hf : cauchy f) =>
      let f' : Cauchy α := { val := f, property := hf };
      (fun
          (this :
          filter.map pure_cauchy f ≤
            filter.lift' (uniformity (Cauchy α)) (set.preimage (Prod.mk f'))) =>
          Exists.intro f'
            (eq.mpr
              (id
                ((fun (ᾰ ᾰ_1 : filter (Cauchy α)) (e_2 : ᾰ = ᾰ_1) (ᾰ_2 ᾰ_3 : filter (Cauchy α))
                    (e_3 : ᾰ_2 = ᾰ_3) => congr (congr_arg LessEq e_2) e_3)
                  (filter.map pure_cauchy f) (filter.map pure_cauchy f)
                  (Eq.refl (filter.map pure_cauchy f)) (nhds f')
                  (filter.lift' (uniformity (Cauchy α)) (uniform_space.ball f'))
                  nhds_eq_uniformity))
              this))
        (filter.le_lift'
          fun (s : set (Cauchy α × Cauchy α)) (hs : s ∈ uniformity (Cauchy α)) => sorry)

protected instance inhabited {α : Type u} [uniform_space α] [Inhabited α] : Inhabited (Cauchy α) :=
  { default := pure_cauchy Inhabited.default }

protected instance nonempty {α : Type u} [uniform_space α] [h : Nonempty α] : Nonempty (Cauchy α) :=
  nonempty.rec_on h fun (a : α) => Nonempty.intro (pure_cauchy a)

def extend {α : Type u} [uniform_space α] {β : Type v} [uniform_space β] (f : α → β) :
    Cauchy α → β :=
  ite (uniform_continuous f) (dense_inducing.extend dense_inducing_pure_cauchy f)
    fun (x : Cauchy α) => f Inhabited.default

theorem extend_pure_cauchy {α : Type u} [uniform_space α] {β : Type v} [uniform_space β]
    [separated_space β] {f : α → β} (hf : uniform_continuous f) (a : α) :
    extend f (pure_cauchy a) = f a :=
  sorry

theorem uniform_continuous_extend {α : Type u} [uniform_space α] {β : Type v} [uniform_space β]
    [separated_space β] [complete_space β] {f : α → β} : uniform_continuous (extend f) :=
  sorry

theorem Cauchy_eq {α : Type u_1} [Inhabited α] [uniform_space α] [complete_space α]
    [separated_space α] {f : Cauchy α} {g : Cauchy α} :
    Lim (subtype.val f) = Lim (subtype.val g) ↔ (f, g) ∈ Mathlib.separation_rel (Cauchy α) :=
  sorry

theorem separated_pure_cauchy_injective {α : Type u_1} [uniform_space α] [s : separated_space α] :
    function.injective fun (a : α) => quotient.mk (pure_cauchy a) :=
  sorry

end Cauchy

namespace uniform_space

protected instance complete_space_separation (α : Type u_1) [uniform_space α]
    [h : complete_space α] : complete_space (quotient (separation_setoid α)) :=
  complete_space.mk
    fun (f : filter (quotient (separation_setoid α))) (hf : cauchy f) =>
      (fun (this : cauchy (filter.comap (fun (x : α) => quotient.mk x) f)) => sorry)
        (cauchy.comap' hf comap_quotient_le_uniformity
          (filter.ne_bot.comap_of_surj (and.left hf)
            fun (b : quotient (separation_setoid α)) => quotient.exists_rep b))

/-- Hausdorff completion of `α` -/
def completion (α : Type u_1) [uniform_space α] := quotient (separation_setoid (Cauchy α))

namespace completion

protected instance inhabited (α : Type u_1) [uniform_space α] [Inhabited α] :
    Inhabited (completion α) :=
  eq.mpr sorry quotient.inhabited

protected instance uniform_space (α : Type u_1) [uniform_space α] : uniform_space (completion α) :=
  id separation_setoid.uniform_space

protected instance complete_space (α : Type u_1) [uniform_space α] :
    complete_space (completion α) :=
  id (uniform_space.complete_space_separation (Cauchy α))

protected instance separated_space (α : Type u_1) [uniform_space α] :
    separated_space (completion α) :=
  id uniform_space.separated_separation

protected instance regular_space (α : Type u_1) [uniform_space α] : regular_space (completion α) :=
  Mathlib.separated_regular

/-- Automatic coercion from `α` to its completion. Not always injective. -/
protected instance has_coe_t (α : Type u_1) [uniform_space α] : has_coe_t α (completion α) :=
  has_coe_t.mk (quotient.mk ∘ Cauchy.pure_cauchy)

protected theorem coe_eq (α : Type u_1) [uniform_space α] :
    coe = quotient.mk ∘ Cauchy.pure_cauchy :=
  rfl

theorem comap_coe_eq_uniformity (α : Type u_1) [uniform_space α] :
    filter.comap (fun (p : α × α) => (↑(prod.fst p), ↑(prod.snd p))) (uniformity (completion α)) =
        uniformity α :=
  sorry

theorem uniform_inducing_coe (α : Type u_1) [uniform_space α] : uniform_inducing coe :=
  uniform_inducing.mk (comap_coe_eq_uniformity α)

theorem dense_range_coe {α : Type u_1} [uniform_space α] : dense_range coe :=
  dense_range.quotient Cauchy.dense_range_pure_cauchy

def cpkg {α : Type u_1} [uniform_space α] : abstract_completion α :=
  abstract_completion.mk (completion α) coe (completion.uniform_space α)
    (completion.complete_space α) (completion.separated_space α) (uniform_inducing_coe α)
    dense_range_coe

protected instance abstract_completion.inhabited (α : Type u_1) [uniform_space α] :
    Inhabited (abstract_completion α) :=
  { default := cpkg }

theorem nonempty_completion_iff (α : Type u_1) [uniform_space α] :
    Nonempty (completion α) ↔ Nonempty α :=
  iff.symm (dense_range.nonempty_iff (abstract_completion.dense cpkg))

theorem uniform_continuous_coe (α : Type u_1) [uniform_space α] : uniform_continuous coe :=
  abstract_completion.uniform_continuous_coe cpkg

theorem continuous_coe (α : Type u_1) [uniform_space α] : continuous coe :=
  abstract_completion.continuous_coe cpkg

theorem uniform_embedding_coe (α : Type u_1) [uniform_space α] [separated_space α] :
    uniform_embedding coe :=
  uniform_embedding.mk (uniform_inducing.mk (comap_coe_eq_uniformity α))
    Cauchy.separated_pure_cauchy_injective

theorem dense_inducing_coe {α : Type u_1} [uniform_space α] : dense_inducing coe :=
  dense_inducing.mk
    (inducing.mk (inducing.induced (uniform_inducing.inducing (uniform_inducing_coe α))))
    dense_range_coe

protected instance separable_space_completion {α : Type u_1} [uniform_space α]
    [topological_space.separable_space α] : topological_space.separable_space (completion α) :=
  dense_inducing.separable_space dense_inducing_coe

theorem dense_embedding_coe {α : Type u_1} [uniform_space α] [separated_space α] :
    dense_embedding coe :=
  dense_embedding.mk
    (dense_inducing.mk (dense_inducing.to_inducing dense_inducing_coe)
      (dense_inducing.dense dense_inducing_coe))
    Cauchy.separated_pure_cauchy_injective

theorem dense_range_coe₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] :
    dense_range fun (x : α × β) => (↑(prod.fst x), ↑(prod.snd x)) :=
  dense_range.prod_map dense_range_coe dense_range_coe

theorem dense_range_coe₃ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] :
    dense_range
        fun (x : α × β × γ) =>
          (↑(prod.fst x), ↑(prod.fst (prod.snd x)), ↑(prod.snd (prod.snd x))) :=
  dense_range.prod_map dense_range_coe dense_range_coe₂

theorem induction_on {α : Type u_1} [uniform_space α] {p : completion α → Prop} (a : completion α)
    (hp : is_closed (set_of fun (a : completion α) => p a)) (ih : ∀ (a : α), p ↑a) : p a :=
  is_closed_property dense_range_coe hp ih a

theorem induction_on₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {p : completion α → completion β → Prop} (a : completion α) (b : completion β)
    (hp : is_closed (set_of fun (x : completion α × completion β) => p (prod.fst x) (prod.snd x)))
    (ih : ∀ (a : α) (b : β), p ↑a ↑b) : p a b :=
  sorry

theorem induction_on₃ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] {p : completion α → completion β → completion γ → Prop}
    (a : completion α) (b : completion β) (c : completion γ)
    (hp :
      is_closed
        (set_of
          fun (x : completion α × completion β × completion γ) =>
            p (prod.fst x) (prod.fst (prod.snd x)) (prod.snd (prod.snd x))))
    (ih : ∀ (a : α) (b : β) (c : γ), p ↑a ↑b ↑c) : p a b c :=
  sorry

theorem ext {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] [t2_space β]
    {f : completion α → β} {g : completion α → β} (hf : continuous f) (hg : continuous g)
    (h : ∀ (a : α), f ↑a = g ↑a) : f = g :=
  abstract_completion.funext cpkg hf hg h

/-- "Extension" to the completion. It is defined for any map `f` but
returns an arbitrary constant value if `f` is not uniformly continuous -/
protected def extension {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    (f : α → β) : completion α → β :=
  abstract_completion.extend cpkg f

@[simp] theorem extension_coe {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} [separated_space β] (hf : uniform_continuous f) (a : α) :
    completion.extension f ↑a = f a :=
  abstract_completion.extend_coe cpkg hf a

theorem uniform_continuous_extension {α : Type u_1} [uniform_space α] {β : Type u_2}
    [uniform_space β] {f : α → β} [separated_space β] [complete_space β] :
    uniform_continuous (completion.extension f) :=
  abstract_completion.uniform_continuous_extend cpkg

theorem continuous_extension {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} [separated_space β] [complete_space β] : continuous (completion.extension f) :=
  abstract_completion.continuous_extend cpkg

theorem extension_unique {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} [separated_space β] [complete_space β] (hf : uniform_continuous f)
    {g : completion α → β} (hg : uniform_continuous g) (h : ∀ (a : α), f a = g ↑a) :
    completion.extension f = g :=
  abstract_completion.extend_unique cpkg hf hg h

@[simp] theorem extension_comp_coe {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    [separated_space β] [complete_space β] {f : completion α → β} (hf : uniform_continuous f) :
    completion.extension (f ∘ coe) = f :=
  abstract_completion.extend_comp_coe cpkg hf

/-- Completion functor acting on morphisms -/
protected def map {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] (f : α → β) :
    completion α → completion β :=
  abstract_completion.map cpkg cpkg f

theorem uniform_continuous_map {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} : uniform_continuous (completion.map f) :=
  abstract_completion.uniform_continuous_map cpkg cpkg f

theorem continuous_map {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} : continuous (completion.map f) :=
  abstract_completion.continuous_map cpkg cpkg f

@[simp] theorem map_coe {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {f : α → β} (hf : uniform_continuous f) (a : α) : completion.map f ↑a = ↑(f a) :=
  abstract_completion.map_coe cpkg cpkg hf a

theorem map_unique {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] {f : α → β}
    {g : completion α → completion β} (hg : uniform_continuous g) (h : ∀ (a : α), ↑(f a) = g ↑a) :
    completion.map f = g :=
  abstract_completion.map_unique cpkg cpkg hg h

@[simp] theorem map_id {α : Type u_1} [uniform_space α] : completion.map id = id :=
  abstract_completion.map_id cpkg

theorem extension_map {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] [complete_space γ] [separated_space γ] {f : β → γ} {g : α → β}
    (hf : uniform_continuous f) (hg : uniform_continuous g) :
    completion.extension f ∘ completion.map g = completion.extension (f ∘ g) :=
  sorry

theorem map_comp {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] {γ : Type u_3}
    [uniform_space γ] {g : β → γ} {f : α → β} (hg : uniform_continuous g)
    (hf : uniform_continuous f) : completion.map g ∘ completion.map f = completion.map (g ∘ f) :=
  extension_map (uniform_continuous.comp (uniform_continuous_coe γ) hg) hf

/- In this section we construct isomorphisms between the completion of a uniform space and the
completion of its separation quotient -/

def completion_separation_quotient_equiv (α : Type u) [uniform_space α] :
    completion (separation_quotient α) ≃ completion α :=
  equiv.mk (completion.extension (separation_quotient.lift coe)) (completion.map quotient.mk) sorry
    sorry

theorem uniform_continuous_completion_separation_quotient_equiv {α : Type u_1} [uniform_space α] :
    uniform_continuous ⇑(completion_separation_quotient_equiv α) :=
  uniform_continuous_extension

theorem uniform_continuous_completion_separation_quotient_equiv_symm {α : Type u_1}
    [uniform_space α] : uniform_continuous ⇑(equiv.symm (completion_separation_quotient_equiv α)) :=
  uniform_continuous_map

protected def extension₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] (f : α → β → γ) : completion α → completion β → γ :=
  abstract_completion.extend₂ cpkg cpkg f

@[simp] theorem extension₂_coe_coe {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] {f : α → β → γ} [separated_space γ]
    (hf : uniform_continuous₂ f) (a : α) (b : β) : completion.extension₂ f ↑a ↑b = f a b :=
  abstract_completion.extension₂_coe_coe cpkg cpkg hf a b

theorem uniform_continuous_extension₂ {α : Type u_1} [uniform_space α] {β : Type u_2}
    [uniform_space β] {γ : Type u_3} [uniform_space γ] (f : α → β → γ) [separated_space γ]
    [complete_space γ] : uniform_continuous₂ (completion.extension₂ f) :=
  abstract_completion.uniform_continuous_extension₂ cpkg cpkg f

protected def map₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β] {γ : Type u_3}
    [uniform_space γ] (f : α → β → γ) : completion α → completion β → completion γ :=
  abstract_completion.map₂ cpkg cpkg cpkg f

theorem uniform_continuous_map₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] (f : α → β → γ) : uniform_continuous₂ (completion.map₂ f) :=
  abstract_completion.uniform_continuous_map₂ cpkg cpkg cpkg f

theorem continuous_map₂ {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] {δ : Type u_4} [topological_space δ] {f : α → β → γ}
    {a : δ → completion α} {b : δ → completion β} (ha : continuous a) (hb : continuous b) :
    continuous fun (d : δ) => completion.map₂ f (a d) (b d) :=
  abstract_completion.continuous_map₂ cpkg cpkg cpkg ha hb

theorem map₂_coe_coe {α : Type u_1} [uniform_space α] {β : Type u_2} [uniform_space β]
    {γ : Type u_3} [uniform_space γ] (a : α) (b : β) (f : α → β → γ) (hf : uniform_continuous₂ f) :
    completion.map₂ f ↑a ↑b = ↑(f a b) :=
  abstract_completion.map₂_coe_coe cpkg cpkg cpkg a b f hf

end Mathlib


/-
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.functor.fully_faithful
import category_theory.functor.reflects_isomorphisms

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 _ ≫ (N : C ⥤ C).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

/-- Construct a monad isomorphism from a natural isomorphism of functors where the forward
direction is a monad morphism. -/
@[simps]
def monad_iso.mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_η' := f_η, app_μ' := f_μ },
  inv :=
  { to_nat_trans := f.inv,
    app_η' := λ X, by simp [←f_η],
    app_μ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_right f,
      simp only [nat_trans.naturality, iso.inv_hom_id_app, assoc, comp_id, f_μ,
        nat_trans.naturality_assoc, iso.inv_hom_id_app_assoc, ←functor.map_comp_assoc],
      simp,
    end } }

/-- Construct a comonad isomorphism from a natural isomorphism of functors where the forward
direction is a comonad morphism. -/
@[simps]
def comonad_iso.mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  M ≅ N :=
{ hom := { to_nat_trans := f.hom, app_ε' := f_ε, app_δ' := f_δ },
  inv :=
  { to_nat_trans := f.inv,
    app_ε' := λ X, by simp [←f_ε],
    app_δ' := λ X,
    begin
      rw ←nat_iso.cancel_nat_iso_hom_left f,
      simp only [reassoc_of (f_δ X), iso.hom_inv_id_app_assoc, nat_trans.naturality_assoc],
      rw [←functor.map_comp, iso.hom_inv_id_app, functor.map_id],
      apply (comp_id _).symm
    end } }

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) := {}.

@[simp]
lemma monad_to_functor_map_iso_monad_iso_mk {M N : monad C} (f : (M : C ⥤ C) ≅ N) (f_η f_μ) :
  (monad_to_functor _).map_iso (monad_iso.mk f f_η f_μ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (monad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (monad_iso.mk (as_iso ((monad_to_functor C).map f)) f.app_η f.app_μ),
    ext; refl,
  end }

/--
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) := {}.

@[simp]
lemma comonad_to_functor_map_iso_comonad_iso_mk {M N : comonad C} (f : (M : C ⥤ C) ≅ N) (f_ε f_δ) :
  (comonad_to_functor _).map_iso (comonad_iso.mk f f_ε f_δ) = f :=
by { ext, refl }

instance : reflects_isomorphisms (comonad_to_functor C) :=
{ reflects := λ M N f i,
  begin
    resetI,
    convert is_iso.of_iso (comonad_iso.mk (as_iso ((comonad_to_functor C).map f)) f.app_ε f.app_δ),
    ext; refl,
  end }

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) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon

Instances for identity and composition functors
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.control.functor
import Mathlib.algebra.group.basic
import Mathlib.PostPort

universes u v u_1 w u_2

namespace Mathlib

theorem applicative.map_seq_map {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {α : Type u} {β : Type u} {γ : Type u} {σ : Type u} (f : α → β → γ) (g : σ → β) (x : F α)
    (y : F σ) : f <$> x <*> g <$> y = (flip function.comp g ∘ f) <$> x <*> y :=
  sorry

theorem applicative.pure_seq_eq_map' {F : Type u → Type v} [Applicative F] [is_lawful_applicative F]
    {α : Type u} {β : Type u} (f : α → β) : Seq.seq (pure f) = Functor.map f :=
  sorry

theorem applicative.ext {F : Type u → Type u_1} {A1 : Applicative F} {A2 : Applicative F}
    [is_lawful_applicative F] [is_lawful_applicative F]
    (H1 : ∀ {α : Type u} (x : α), pure x = pure x)
    (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α), f <*> x = f <*> x) : A1 = A2 :=
  sorry

protected instance id.is_comm_applicative : is_comm_applicative id :=
  is_comm_applicative.mk fun (α β : Type u_1) (a : id α) (b : id β) => Eq.refl (Prod.mk <$> a <*> b)

namespace functor

namespace comp

theorem map_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} (f : α → β)
    (x : α) : f <$> pure x = pure (f x) :=
  sorry

theorem seq_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v}
    (f : comp F G (α → β)) (x : α) : f <*> pure x = (fun (g : α → β) => g x) <$> f :=
  sorry

theorem seq_assoc {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} {γ : Type v}
    (x : comp F G α) (f : comp F G (α → β)) (g : comp F G (β → γ)) :
    g <*> (f <*> x) = function.comp <$> g <*> f <*> x :=
  sorry

theorem pure_seq_eq_map {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G] {α : Type v} {β : Type v} (f : α → β)
    (x : comp F G α) : pure f <*> x = f <$> x :=
  sorry

protected instance is_lawful_applicative {F : Type u → Type w} {G : Type v → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] :
    is_lawful_applicative (comp F G) :=
  is_lawful_applicative.mk pure_seq_eq_map map_pure seq_pure seq_assoc

theorem applicative_id_comp {F : Type u_1 → Type u_2} [AF : Applicative F]
    [LF : is_lawful_applicative F] : comp.applicative = AF :=
  applicative.ext (fun (α : Type u_1) (x : α) => rfl)
    fun (α β : Type u_1) (f : F (α → β)) (x : F α) => rfl

theorem applicative_comp_id {F : Type u_1 → Type u_2} [AF : Applicative F]
    [LF : is_lawful_applicative F] : comp.applicative = AF :=
  sorry

protected instance is_comm_applicative {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) :=
  sorry

end comp

end functor

theorem comp.seq_mk {α : Type w} {β : Type w} {f : Type u → Type v} {g : Type w → Type u}
    [Applicative f] [Applicative g] (h : f (g (α → β))) (x : f (g α)) :
    functor.comp.mk h <*> functor.comp.mk x = functor.comp.mk (Seq.seq <$> h <*> x) :=
  rfl

protected instance functor.const.applicative {α : Type u_1} [HasOne α] [Mul α] :
    Applicative (functor.const α) :=
  sorry

protected instance functor.const.is_lawful_applicative {α : Type u_1} [monoid α] :
    is_lawful_applicative (functor.const α) :=
  sorry

protected instance functor.add_const.applicative {α : Type u_1} [HasZero α] [Add α] :
    Applicative (functor.add_const α) :=
  sorry

protected instance functor.add_const.is_lawful_applicative {α : Type u_1} [add_monoid α] :
    is_lawful_applicative (functor.add_const α) :=
  sorry

end Mathlib