import classes.unrestricted.basics.definition

/-- Transformation rule for a grammar in the Kuroda normal form. -/
inductive kuroda_rule (T : Type) (N : Type)
| two_two (A B C D : N)   : kuroda_rule
| one_two (A B C : N)     : kuroda_rule
| one_one (A : N) (t : T) : kuroda_rule
| one_nil (A : N)         : kuroda_rule

/-- Grammar in the Kuroda normal form that generates words
    over the alphabet `T` (a type of terminals). -/
structure kuroda_grammar (T : Type) :=
(nt : Type)
(initial : nt)
(rules : list (kuroda_rule T nt))

def grule_of_kuroda_rule {T : Type} {N : Type} : kuroda_rule T N → grule T N
| (kuroda_rule.two_two A B C D) := grule.mk [] A [symbol.nonterminal B] [symbol.nonterminal C, symbol.nonterminal D]
| (kuroda_rule.one_two A B C)   := grule.mk [] A [] [symbol.nonterminal B, symbol.nonterminal C]
| (kuroda_rule.one_one A t)     := grule.mk [] A [] [symbol.terminal t]
| (kuroda_rule.one_nil A)       := grule.mk [] A [] []

def grammar_of_kuroda_grammar {T : Type} (k : kuroda_grammar T) : grammar T :=
grammar.mk k.nt k.initial (list.map grule_of_kuroda_rule k.rules)

theorem kuroda_grammar_always_exists {T : Type} (L : language T) :
  is_RE L  →  ∃ k : kuroda_grammar T, grammar_language (grammar_of_kuroda_grammar k) = L  :=
sorry


/-
# Generalized rewriting
-/

import GeneralizedRewriting.Defs
import GeneralizedRewriting.Eauto
import Lean

open Lean Meta Elab Tactic

/-
## Outline algorithm

This algorithm produces a "outline" of the proof for a rewrite. It provides
the main structure, but leaves two elements undefined (through metavariables):

1. Which relations to use in the codomain of relevant function calls;
2. Which subrelation instances to use.

It produces a set of typeclass queries for `Proper` and `Subrel` which
reference subterms of the goal as well as newly-introduced metavariables for
relations to guess.

Note that `Subrel` could in principle be used everywhere, which makes it rather
difficult to deal with. The algorithm makes simplifications by assuming that
the set of instances of `Subrel` is:

- Transitive;
- Closed under `pointwise_relation`,

in order to generate a workable set of queries. If the set of instances of
`Subrel` does not satisfy the following requirements, the rewriting tactic may
fail to generate a proof that the rewrite is correct.

Based on:
[1] Sozeau, M. 2009. A New Look at Generalized Rewriting in Type Theory.
    Journal of Formalized Reasoning. 2, 1 (Jan. 2009), 41–62.
    DOI:https://doi.org/10.6092/issn.1972-5787/1574.
-/

initialize
  registerTraceClass `Meta.Tactic.grewrite

inductive SelectionCriterion where
  | Only (occs: Array Nat)
  | AllBut (occs: Array Nat)

def SelectionCriterion.selects: SelectionCriterion → Nat → Bool
  | Only occs => occs.contains
  | AllBut occs => not ∘ occs.contains

-- Environment where the outline algorithm is run

structure RewriteState where
  -- Rewrite to apply: ρ ≡ ρ_R ρ_t ρ_u
  ρ: Expr
  ρ_R: Expr
  ρ_t: Expr
  ρ_u: Expr
  -- Proof of ρ
  ρ_proof: Expr
  -- Number of occurrences found so far, and selected
  occsFound: Nat
  occsSelected: Nat
  -- Selection criterion
  selection: SelectionCriterion

abbrev RewriteM := StateT RewriteState TacticM

/-
Inputs:
  t -- Input term
  ρ -- Rewriting lemma (of the form `∀ ϕ…, R α… t u`) (in `RewriteState`)
Outputs:
  u -- Rewritten term
  R -- Relation for rewriting (contains metavariables)
  p -- Proof of rewrite
  ψ -- Typeclass queries that need solving
  N -- Number of occurences of the rewrite found in `t` (in `RewriteState`)
-/
partial def outline (t: Expr): RewriteM (Expr × Expr × Expr × Array Expr) := do
  let t ← whnf t
  withTraceNode `Meta.Tactic.grewrite (fun _ => return m!"outline: {t}") do
  let state ← get

  -- [UNIFY]: If t unifies with the LHS of ρ then we have an occurrence, and we
  -- can apply ρ directly.
  if ← isDefEq t state.ρ_t then
    trace[Meta.Tactic.grewrite] "using rule: UNIFY"
    let Nf := state.occsFound
    let Ns := state.occsSelected
    -- Occurrences are numbered starting at 1.
    let selected := state.selection.selects (Nf+1)
    set { state with occsFound := Nf + 1, occsSelected := Ns + (if selected then 1 else 0) }
    if selected then
      return (state.ρ_u, state.ρ_R, state.ρ_proof, #[])

  -- [APP]: If t is an app `f e` where f is of non-dependent function type
  -- `τ → σ`, guess a relation `?m_T: relation σ` for the co-domain. This is
  -- also the place where we allow `Subrel` instances.
  if let .app f e := t then
    let type_f ← whnf (← inferType f)
    if let some (_, σ) := type_f.arrow? then
        trace[Meta.Tactic.grewrite] "using rule: APP (function type: {type_f})"
        let (f', F, pf, ψf) ← outline f
        let (e', E, pe, ψe) ← outline e
        let m_T ← mkFreshExprMVar (← mkAppM ``relation #[σ])
        let m_sub ← mkFreshExprMVar (← mkAppM ``Subrel #[F, ← mkAppM ``respectful #[E, m_T]])
        let p ← mkAppOptM ``Subrel.prf #[none, none, none, m_sub, f, f', pf, e, e', pe]
        -- Very important order of constraints: first the argument, then the
        -- function, once the relation on the argument has been guessed
        return (mkApp f' e', m_T, p, (ψe ++ ψf).push m_sub)

  -- TODO: [ARROW], [LAMBDA] and [FORALL]
  -- TODO: Can the rewrite of [impl τ₁ τ₂] in ARROW not return an impl?

  -- [ATOM]: Default to requiring `Proper` on the atom for a suitable relation
  trace[Meta.Tactic.grewrite] "using rule: ATOM ({← whnf t})"
  let τ ← inferType t
  let m_S ← mkFreshExprMVar (← mkAppM ``relation #[τ])
  let m_Proper ← mkFreshExprMVar (← mkAppM ``Proper #[m_S, t])
  let p ← mkAppOptM ``Proper.prf #[none, none, none, m_Proper]
  return (t, m_S, p, #[m_Proper])

def outlineMain (t: Expr): RewriteM (Expr × Expr × Expr × Array Expr) := do
  -- At the top-level, we need to rewrite for any relation which is a
  -- subrelation of `flip impl`.
  -- TODO: To rewrite in a hypothesis, use a subrelation of `impl`.
  let (u, R, p, ψ) ← outline t
  let MainSubrel ← mkAppM ``Subrel #[R, ← mkAppM ``flip #[mkConst ``impl]]
  let m_sub ← mkFreshExprMVar MainSubrel
  let p' ← mkAppOptM ``Subrel.prf #[none, none, none, m_sub, none, none, p]
  return (u, R, p', ψ.push m_sub)

def grewrite (h: Expr) (occs: SelectionCriterion): TacticM Unit :=
  withMainContext do
    let goal ← getMainGoal
    let goalType ← goal.getType
    let ρ ← inferType (← whnf h)

    match ρ with
    | .app (.app ρ_R ρ_t) ρ_u =>
        let st: RewriteState := {
          ρ, ρ_R, ρ_t, ρ_u,
          ρ_proof := h,
          occsFound := 0,
          occsSelected := 0,
          selection := occs }
        let ((_, _, p, ψ), st') ← outlineMain goalType st |>.run
        let Ns := st'.occsSelected

        trace[Meta.Tactic.grewrite] "{st'.occsFound} occurrences found, {Ns} selected"
        if Ns = 0 then
          throwError "grewrite: no occurrence found or none selected"

        let pp ← ψ.mapM fun e => do return f!"\n{← ppExpr (← inferType e)}"
        trace[Meta.Tactic.grewrite] "constraints to solve: {Format.join pp.toList}"

        -- Try to solve the constraints with `typeclasses_eauto with grewrite`
        let success ← Eauto.eautoMain (ψ.map Expr.mvarId!).toList #[`grewrite] true
        if !success then
          throwError "grewrite: unable to solve constraints"

        let subgoals ← goal.apply (← instantiateMVars p)
        replaceMainGoal subgoals
    | _ =>
        throwError f!"unable to interpret {ρ} as a relation"
        return
    return

-- Tactic front-end

elab "grewrite " h:term : tactic => do
  let h ← elabTerm h .none
  grewrite h (.AllBut #[])

elab "grewrite " h:term " at " neg:"-"? occs:num+ : tactic => do
  let h ← elabTerm h .none
  let occs := occs.map TSyntax.getNat
  let selection: SelectionCriterion :=
    match neg with
    | none => .Only occs
    | _ => .AllBut occs
  grewrite h selection


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Jesse Michael Han
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.rcases
import Mathlib.data.sum
import Mathlib.logic.function.basic
import Mathlib.PostPort

universes r s u u_1

namespace Mathlib

/--
`derive_struct_ext_lemma n` generates two extensionality lemmas based on
the equality of all non-propositional projections.

On the following:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

`derive_struct_lemma` generates:

```lean
lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
  x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
  x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
def ext_param_type := Option name ⊕ Option name

/--
For performance reasons, it is inadvisable to use `user_attribute.get_param`.
The parameter is stored as a reflected expression.  When calling `get_param`,
the stored parameter is evaluated using `eval_expr`, which first compiles the
expression into VM bytecode. The unevaluated expression is available using
`user_attribute.get_param_untyped`.

In particular, `user_attribute.get_param` MUST NEVER BE USED in the
implementation of an attribute cache. This is because calling `eval_expr`
disables the attribute cache.

There are several possible workarounds:
 1. Set a different attribute depending on the parameter.
 2. Use your own evaluation function instead of `eval_expr`, such as e.g. `expr.to_nat`.
 3. Write your own `has_reflect Param` instance (using a more efficient serialization format).
   The `user_attribute` code unfortunately checks whether the expression has the correct type,
   but you can use `` `(id %%e : Param) `` to pretend that your expression `e` has type `Param`.
-/
/-!
For performance reasons, the parameters of the `@[ext]` attribute are stored
in two auxiliary attributes:
```lean
attribute [ext [thunk]] funext

-- is turned into

-- is turned into
attribute [_ext_core (@id name @funext)] thunk
attribute [_ext_lemma_core] funext
```

see Note [user attribute parameters]
-/

/-- Private attribute used to tag extensionality lemmas. -/
/--
Returns the extensionality lemmas in the environment, as a map from structure
name to lemma name.
-/
/--
Returns the extensionality lemmas in the environment, as a list of lemma names.
-/
/--
Tag lemmas of the form:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The attribute indexes extensionality lemma using the type of the
objects (i.e. `my_collection`) which it gets from the statement of
the lemma.  In some cases, the same lemma can be used to state the
extensionality of multiple types that are definitionally equivalent.

```lean
attribute [ext [(→),thunk,stream]] funext
```

Those parameters are cumulative. The following are equivalent:

```lean
attribute [ext [(→),thunk]] funext
attribute [ext [stream]] funext
```
and
```lean
attribute [ext [(→),thunk,stream]] funext
```

One removes type names from the list for one lemma with:
```lean
attribute [ext [-stream,-thunk]] funext
```

Also, the following:

```lean
@[ext]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

is equivalent to

```lean
@[ext *]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

This allows us specify type synonyms along with the type
that is referred to in the lemma statement.

```lean
@[ext [*,my_type_synonym]]
lemma my_collection.ext (a b : my_collection)
  (h : ∀ x, a.lookup x = b.lookup y) :
  a = b := ...
```

The `ext` attribute can be applied to a structure to generate its extensionality lemmas:

```lean
@[ext]
structure foo (α : Type*) :=
(x y : ℕ)
(z : {z // z < x})
(k : α)
(h : x < y)
```

will generate:

```lean
@[ext] lemma foo.ext : ∀ {α : Type u_1} (x y : foo α),
x.x = y.x → x.y = y.y → x.z == y.z → x.k = y.k → x = y
lemma foo.ext_iff : ∀ {α : Type u_1} (x y : foo α),
x = y ↔ x.x = y.x ∧ x.y = y.y ∧ x.z == y.z ∧ x.k = y.k
```

-/
/--
When possible, `ext` lemmas are stated without a full set of arguments. As an example, for bundled
homs `f`, `g`, and `of`, `f.comp of = g.comp of → f = g` is a better `ext` lemma than
`(∀ x, f (of x) = g (of x)) → f = g`, as the former allows a second type-specific extensionality
lemmas to be applied to `f.comp of = g.comp of`.
If the domain of `of` is `ℕ` or `ℤ` and `of` is a `ring_hom`, such a lemma could then make the goal
`f (of 1) = g (of 1)`.

For bundled morphisms, there is a `ext` lemma that always applies of the form
`(∀ x, ⇑f x = ⇑g x) → f = g`. When adding type-specific `ext` lemmas like the one above, we want
these to be tried first. This happens automatically since the type-specific lemmas are inevitably
defined later.
-/
-- We mark some existing extensionality lemmas.

-- We create some extensionality lemmas for existing structures.

theorem ulift.ext {α : Type s} (x : ulift α) (y : ulift α) (h : ulift.down x = ulift.down y) :
    x = y :=
  sorry

namespace plift

-- This is stronger than the one generated automatically.

theorem ext {P : Prop} (a : plift P) (b : plift P) : a = b :=
  cases_on a fun (a : P) => cases_on b fun (b : P) => Eq.refl (up a)

end plift

-- Conservatively, we'll only add extensionality lemmas for `has_*` structures

-- as they become useful.

theorem has_zero.ext_iff {α : Type u} (x : HasZero α) (y : HasZero α) : x = y ↔ 0 = 0 := sorry

theorem unit.ext {x : Unit} {y : Unit} : x = y :=
  punit.cases_on x (punit.cases_on y (Eq.refl PUnit.unit))

theorem punit.ext {x : PUnit} {y : PUnit} : x = y :=
  punit.cases_on x (punit.cases_on y (Eq.refl PUnit.unit))

namespace tactic

/-- Helper structure for `ext` and `ext1`. `lemmas` keeps track of extensionality lemmas
  applied so far. -/
/-- Helper function for `try_intros`. Additionally populates the `trace_msg` field
  of `ext_state`. -/
/-- Try to introduce as many arguments as possible, using the given patterns to destruct the
  introduced variables. Returns the unused patterns. -/
/-- Apply one extensionality lemma, and destruct the arguments using the patterns
  in the ext_state. -/
/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns. -/
/-- Apply one extensionality lemma, and destruct the arguments using the given patterns.
  Returns the unused patterns. -/
/-- Apply multiple extensionality lemmas, destructing the arguments using the given patterns.
  `ext ps (some n)` applies at most `n` extensionality lemmas. Returns the unused patterns. -/
/--
`ext1 id` selects and apply one extensionality lemma (with attribute
`ext`), using `id`, if provided, to name a local constant
introduced by the lemma. If `id` is omitted, the local constant is
named automatically, as per `intro`. Placing a `?` after `ext1`
 (e.g. `ext1? i ⟨a,b⟩ : 3`) will display a sequence of tactic
applications that can replace the call to `ext1`.
-/
/--
- `ext` applies as many extensionality lemmas as possible;
- `ext ids`, with `ids` a list of identifiers, finds extentionality and applies them
  until it runs out of identifiers in `ids` to name the local constants.
- `ext` can also be given an `rcases` pattern in place of an identifier.
  This will destruct the introduced local constant.
- Placing a `?` after `ext` (e.g. `ext? i ⟨a,b⟩ : 3`) will display
  a sequence of tactic applications that can replace the call to `ext`.

When trying to prove:

```lean
α β : Type,
f g : α → set β
⊢ f = g
```

applying `ext x y` yields:

```lean
α β : Type,
f g : α → set β,
x : α,
y : β
⊢ y ∈ f x ↔ y ∈ f x
```

by applying functional extensionality and set extensionality.

When trying to prove:

```lean
α β γ : Type
f g : α × β → γ
⊢ f = g
```

applying `ext ⟨a, b⟩` yields:

```lean
α β γ : Type,
f g : α × β → γ,
a : α,
b : β
⊢ f (a, b) = g (a, b)
```

by applying functional extensionality and destructing the introduced pair.

In the previous example, applying `ext? ⟨a,b⟩` will produce the trace message:

```lean
Try this: apply funext, rintro ⟨a, b⟩
```

A maximum depth can be provided with `ext x y z : 3`.
-/
/--
* `ext1 id` selects and apply one extensionality lemma (with
end Mathlib


theorem ex {i j : Fin n} (h : i = j) : i.val = j.val :=
  h ▸ rfl

attribute [-appUnexpander] unexpandEqNDRec

#print ex


import sets.algebra init2 sets.axioms sets.theories categories.basic

universes v v' v'' v''' u u' u'' u''' w
hott_theory

namespace hott
open hott.eq hott.set hott.subset hott.is_trunc hott.is_equiv hott.equiv hott.categories
     hott.trunc

namespace categories

/- To construct the opposite category, we use the mathlib-trick in [data.opposite]
   that allows the elaborator to do most of the work. -/
variables {C : Type u} {D : Type u'} {E : Type u''} {F : Type u'''}

@[hott]
def opposite : Type u := C

notation C `ᵒᵖ`:std.prec.max_plus := @opposite C

@[hott]
def op_Set (C : Set.{u}) : Set :=
  Set.mk Cᵒᵖ (C.struct)

namespace opposite

/-- The canonical map `C → Cᵒᵖ`. -/
@[hott]
def op : C → Cᵒᵖ := id
/-- The canonical map `Cᵒᵖ → C`. -/
@[hott]
def unop : Cᵒᵖ → C := id

@[hott, hsimp]
def op_inj_iff (x y : C) : op x = op y ↔ x = y := iff.rfl

@[hott, hsimp]
def unop_inj_iff (x y : Cᵒᵖ) : unop x = unop y ↔ x = y := iff.rfl

@[hott, hsimp]
def op_unop (x : Cᵒᵖ) : op (unop x) = x := rfl

@[hott, hsimp]
def unop_op (x : C) : unop (op x) = x := rfl

attribute [irreducible] opposite

end opposite

open opposite

@[hott]
instance has_hom.opposite [has_hom.{v} C] : has_hom Cᵒᵖ :=
  has_hom.mk (λ x y, unop y ⟶ unop x) /- Why can't we define a `has_hom` structure with `{}`? -/

/- The opposite of a morphism in `C`. -/
@[hott, reducible]
def hom_op [has_hom.{v} C] {x y : C} (f : x ⟶ y) : op y ⟶ op x := f
/- Given a morphism in `Cᵒᵖ`, we can take the "unopposite" back in `C`. -/
@[hott]
def hom_unop [has_hom.{v} C] {x y : Cᵒᵖ} (f : x ⟶ y) : unop y ⟶ unop x := f

attribute [irreducible] has_hom.opposite /- Why can't you change this name to `has_hom_opp`? -/

@[hott, hsimp]
def hom_unop_op [has_hom.{v} C] {x y : C} {f : x ⟶ y} : hom_unop (hom_op f) = f := rfl

@[hott, hsimp]
def hom_op_unop [has_hom.{v} C] {x y : Cᵒᵖ} {f : x ⟶ y} : hom_op (hom_unop f) = f := rfl

/- The opposite precategory. -/
@[hott, instance]
def category_struct.opposite [precategory.{v} C] : category_struct.{v} Cᵒᵖ :=
  category_struct.mk (λ x, hom_op (𝟙 (unop x)))
                     (λ _ _ _ f g, hom_op (hom_unop g ≫ hom_unop f))

@[hott]
def id_comp_op [precategory.{v} C] : ∀ (x y : Cᵒᵖ) (f : x ⟶ y), 𝟙 x ≫ f = f :=
begin intros x y f, hsimp end

@[hott]
def comp_id_op [precategory.{v} C] : ∀ (x y : Cᵒᵖ) (f : x ⟶ y), f ≫ 𝟙 y = f :=
begin intros x y f, hsimp end

@[hott]
def assoc_op [precategory.{v} C] : ∀ (x y z w : Cᵒᵖ) (f : x ⟶ y) (g : y ⟶ z) (h : z ⟶ w),
  (f ≫ g) ≫ h = f ≫ g ≫ h :=
begin
  intros x y z w f g h,
  change hom_op (hom_unop h ≫ hom_unop (hom_op (hom_unop g ≫ hom_unop f))) =
         hom_op (hom_unop (hom_op (hom_unop h ≫ hom_unop g)) ≫ hom_unop f),
  hsimp
end

@[hott, instance]
def precategory.opposite [precategory.{v} C] : precategory.{v} Cᵒᵖ :=
  precategory.mk id_comp_op comp_id_op assoc_op

@[hott]
def hom_op_funct [precategory.{v} C] {a b c : C} (f : a ⟶ b) (g : b ⟶ c) :
  hom_op (f ≫ g) = hom_op g ≫ hom_op f := rfl

/- The opposite category.
   We show the equivalence by splitting it up in three steps and using that maps from
   `a = b` are determined by `rfl` if `a` and `b` are allowed to vary freely. -/
@[hott, hsimp]
def id_op_to_id [precategory.{v} C] : Π {a b : Cᵒᵖ}, (a = b) -> (unop a = unop b) :=
  begin intros a b p, hinduction p, exact rfl end

@[hott, hsimp]
def id_to_id_op [precategory.{v} C] : Π {a b : Cᵒᵖ}, (unop a = unop b) -> (a = b) :=
  assume a b p_op,
  calc a   = op (unop a) : by hsimp
       ... = op (unop b) : ap op p_op
       ... = b : op_unop b

@[hott, instance]
def id_op_eqv_id [precategory.{v} C] : ∀ a b : Cᵒᵖ, is_equiv (@id_op_to_id _ _ a b) :=
  assume a b,
  have rinv : ∀ p_op : unop a = unop b, id_op_to_id (id_to_id_op p_op) = p_op, from
    begin intro p_op, hsimp, rwr ap_compose', hsimp end,
  have linv : ∀ p : a = b, id_to_id_op (id_op_to_id p) = p, from
    begin intro p, hsimp, rwr ap_compose', hsimp end,
  is_equiv.adjointify id_op_to_id id_to_id_op rinv linv

@[hott, hsimp]
def iso_to_iso_op [precategory.{v} C] : ∀ {a b : Cᵒᵖ}, (unop a ≅ unop b) -> (a ≅ b) :=
begin
  intros a b i,
  fapply iso.mk,
    rwr <- op_unop a, rwr <- op_unop b, exact hom_op i.inv,
    rwr <- op_unop a, rwr <- op_unop b, exact hom_op i.hom,
    change hom_op (i.inv ≫ i.hom) = hom_op (𝟙 (unop b)), apply ap hom_op, exact i.r_inv,
    change hom_op (i.hom ≫ i.inv) = hom_op (𝟙 (unop a)), apply ap hom_op, exact i.l_inv
end

@[hott, hsimp]
def iso_op_to_iso [precategory.{v} C] : ∀ {a b : Cᵒᵖ}, (a ≅ b) -> (unop a ≅ unop b) :=
begin
  intros a b i,
  fapply iso.mk,
    exact hom_unop i.inv,
    exact hom_unop i.hom,
  { rwr <- @hom_unop_op _ _ _ _ (hom_unop i.hom ≫ hom_unop i⁻¹ʰ),
    rwr <- @hom_unop_op _ _ _ _ (𝟙 (unop b)), exact ap hom_unop (i.r_inv) },
  { rwr <- @hom_unop_op _ _ _ _ (hom_unop i⁻¹ʰ ≫ hom_unop i.hom),
    rwr <- @hom_unop_op _ _ _ _ (𝟙 (unop a)), exact ap hom_unop (i.l_inv) }
end

@[hott, instance]
def iso_eqv_iso_op [precategory.{v} C] : ∀ a b : Cᵒᵖ, is_equiv (@iso_to_iso_op _ _ a b) :=
  assume a b,
  have rinv : ∀ h : a ≅ b, iso_to_iso_op (iso_op_to_iso h) = h, from
    assume h,
    have hom_eq : (iso_to_iso_op (iso_op_to_iso h)).hom = h.hom, by hsimp,
    hom_eq_to_iso_eq hom_eq,
  have linv : ∀ h_op : unop a ≅ unop b, iso_op_to_iso (iso_to_iso_op h_op) = h_op, from
    assume h_op,
    have hom_eq : (iso_op_to_iso (iso_to_iso_op h_op)).hom = h_op.hom, by hsimp,
    hom_eq_to_iso_eq hom_eq,
  is_equiv.adjointify iso_to_iso_op iso_op_to_iso rinv linv

/- This lemma should belong to [init.path]. Needs function extensionality. -/
@[hott]
def fn_id_rfl {A : Type u} {B : A -> A -> Type v}
  (f g : ∀ {a b : A}, (a = b) -> B a b) :
  (∀ a : A, f (@rfl _ a) = g (@rfl _ a)) -> ∀ a b : A, @f a b = @g a b :=
assume fn_rfl_eq,
have fn_hom_eq : ∀ (a b : A) (p : a = b), @f a b p = @g a b p, from
  begin intros a b p, hinduction p, exact fn_rfl_eq a end,
assume a b,
eq_of_homotopy (fn_hom_eq a b)

@[hott]
def idtoiso_rfl_eq [category.{v} C] : ∀ a : Cᵒᵖ,
  iso_to_iso_op (idtoiso (id_op_to_id (@rfl _ a))) =
  idtoiso (@rfl _ a) :=
begin intro a, apply hom_eq_to_iso_eq, change 𝟙 a = 𝟙 a, refl end

@[hott, instance]
def ideqviso_op [category.{v} C] : ∀ a b : Cᵒᵖ, is_equiv (@idtoiso _ _ a b) :=
  assume a b,
  let f := @id_op_to_id _ _ a b, g := @idtoiso _ _ (unop a) (unop b),
      h := @iso_to_iso_op _ _ a b in
  have id_optoiso_op : is_equiv (h ∘ g ∘ f), from is_equiv_compose h (g ∘ f),
  let hgf := λ (a b : Cᵒᵖ) (p : a = b),
             iso_to_iso_op (idtoiso (id_op_to_id p)) in
  have idtoiso_eq : hgf a b = @idtoiso _ _ a b, from fn_id_rfl _ _ idtoiso_rfl_eq a b,
  begin rwr <- idtoiso_eq; exact id_optoiso_op end

@[hott, instance]
def category.opposite [category.{v} C] : category.{v} Cᵒᵖ :=
  category.mk ideqviso_op

@[hott]
def opposite_functor [precategory.{v} C] [precategory.{v'} D] : (C ⥤ D) -> (Cᵒᵖ ⥤ Dᵒᵖ) :=
begin
  intro F, fapply functor.mk,
  { intro c, exact op (F.obj (unop c)) },
  { intros x y f, apply hom_op, exact F.map (hom_unop f) },
  { intro x, hsimp, refl },
  { intros x y z f g, hsimp, refl }
end

/- The type of functors between two precategories has a precategory
   structure: The morphisms are the natural transformations, and the type of natural
   transformations between two given functors is a set. -/
@[hott]
def nat_trans_eq [precategory.{v} C] [precategory.{v'} D] {F G : C ⥤ D} {φ ψ : F ⟹ G} :
  (φ.app = ψ.app) -> φ = ψ :=
begin
  intros, hinduction φ, hinduction ψ, apply apd011 nat_trans.mk a,
  apply pathover_of_tr_eq, apply eq_of_homotopy3, intros c₁ c₂ f, exact is_prop.elim _ _
end

@[hott]
def nat_trans_eq_idp [precategory.{v} C] [precategory.{v'} D] {F G : C ⥤ D} (φ : F ⟹ G) :
  @nat_trans_eq _ _ _ _ _ _ φ φ idp = idp :=
begin
  hinduction φ, hsimp,
  change apd011 nat_trans.mk idp (pathover_idp_of_eq _ _) = _, hsimp,
  have H : (λ (c₁ c₂ : C) (f : c₁ ⟶ c₂), is_prop.elim (naturality f) (naturality f)) =
           λ (c₁ c₂ : C) (f : ↥(c₁ ⟶ c₂)), idp, from
  begin apply eq_of_homotopy3, intros c₁ c₂ f,  exact is_prop_elim_self _ end,
  rwr H, rwr eq_of_homotopy3_id
end

@[hott]
def nat_trans_eq_eta [precategory.{v} C] [precategory.{v'} D] {F G : C ⥤ D} {φ ψ : F ⟹ G}
  (p : φ = ψ) : nat_trans_eq (ap nat_trans.app p) = p :=
begin hinduction p, hinduction φ, rwr ap_idp, rwr nat_trans_eq_idp _ end

@[hott, instance]
def nat_trans_is_set [precategory.{v} C] [precategory.{v'} D] :
  Π F G : C ⥤ D, is_set (F ⟹ G) :=
begin
  intros F G, apply is_set.mk, intros s t p q,
  rwr <- nat_trans_eq_eta p, rwr <- nat_trans_eq_eta q,
  apply ap nat_trans_eq, exact is_set.elim _ _
end

@[hott, instance]
def functor_has_hom [precategory.{v} C] [precategory.{v'} D] : has_hom (C ⥤ D) :=
  has_hom.mk (λ F G : C ⥤ D, to_Set (F ⟹ G))

@[hott, reducible]
def nat_trans_id [precategory.{v} C] [precategory.{v'} D] (F : C ⥤ D) : F ⟹ F :=
  nat_trans.mk (λ c : C, 𝟙 (F.obj c)) (λ (c c' : C) (f : c ⟶ c'), by hsimp)

@[hott, reducible]
def nat_trans_comp [precategory.{v} C] [precategory.{v'} D] (F G H : C ⥤ D)
  (α : F ⟹ G) (β : G ⟹ H) : F ⟹ H :=
nat_trans.mk (λ c, α.app c ≫ β.app c)
             (λ (c c' : C) (f : c ⟶ c'), by rwr <- precategory.assoc (F.map f) _ _;
                      rwr nat_trans.naturality; rwr precategory.assoc (α.app c) _ _;
                      rwr nat_trans.naturality; rwr precategory.assoc (α.app c))

@[hott, instance]
def functor_cat_struct [precategory.{v} C] [precategory.{v'} D] :
  category_struct (C ⥤ D) :=
category_struct.mk (λ F, nat_trans_id F) (λ F G H α β, nat_trans_comp F G H α β)

@[hott, instance]
def functor_precategory [precategory.{v} C] [precategory.{v'} D] :
  precategory (C ⥤ D) :=
begin
  fapply precategory.mk,
  { intros F G s, apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change 𝟙 (F.obj c) ≫ s.app c = _, rwr precategory.id_comp },
  { intros F G s, apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change s.app c ≫ 𝟙 (G.obj c) = _, rwr precategory.comp_id },
  { intros E F G H s t u, apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (s.app c ≫ t.app c) ≫ u.app c = s.app c ≫ t.app c ≫ u.app c,
    rwr precategory.assoc }
end

/- If the target of the functors is a category, the precategory of functors is a category. -/
@[hott]
def functor_iso_to_isos [precategory.{v} C] [precategory.{v'} D] {F G : C ⥤ D} :
  (F ≅ G) -> Π c : C, F.obj c ≅ G.obj c :=
begin
  intros i c, fapply iso.mk,
  { exact i.hom.app c },
  { exact i.inv.app c },
  { change (i.inv ≫ i.hom).app c = _, rwr i.r_inv },
  { change (i.hom ≫ i.inv).app c = _, rwr i.l_inv }
end

@[hott]
def functor_isoid_to_isoids [precategory.{v} C] [precategory.{v'} D] {F : C ⥤ D} :
  Π (c : C), functor_iso_to_isos (id_is_iso F) c = id_is_iso (F.obj c) :=
begin intro c, apply hom_eq_to_iso_eq, refl end

@[hott]
def functor_idtoiso_comp [precategory.{v} C] [precategory.{v'} D] {F G : C ⥤ D}
  (p : F = G) (c : C) :
  nat_trans.app (idtoiso p).hom c = (idtoiso (apd10 (ap functor.obj p) c)).hom :=
begin hinduction p, rwr idtoiso_refl_eq end

@[hott]
def functor_isotoid [precategory.{v} C] [category.{v'} D] {F G : C ⥤ D} :
  (F ≅ G) -> F = G :=
begin
  have Q : Π (H₂ : C -> D) (p : F.obj = H₂) (c₁ c₂ : C) (h : c₁ ⟶ c₂),
            (p ▸[λ H : C -> D, Π (c₁ c₂ : C) (h : c₁ ⟶ c₂), H c₁ ⟶ H c₂] F.map) c₁ c₂ h =
               (idtoiso (apd10 p c₁)).inv ≫ F.map h ≫ (idtoiso (apd10 p c₂)).hom, from
    begin intros H₂ p c₁ c₂ h, hinduction p, hsimp end,
  intro i, fapply functor_eq,
  { apply eq_of_homotopy, intro c, exact category.isotoid (functor_iso_to_isos i c) },
  { apply pathover_of_tr_eq, apply eq_of_homotopy3, intros c₁ c₂ h, rwr Q,
    rwr homotopy_eq_rinv,
    change (idtoiso (idtoiso⁻¹ᶠ (functor_iso_to_isos i c₁)))⁻¹ʰ ≫ _ ≫
           (idtoiso (idtoiso⁻¹ᶠ (functor_iso_to_isos i c₂))).hom = _,
    rwr category.idtoiso_rinv, rwr category.idtoiso_rinv, apply eq.inverse,
    apply iso_move_lr, change i.hom.app c₁ ≫ _ = _ ≫ i.hom.app c₂, rwr i.hom.naturality }
end

@[hott, instance]
def functor_category [precategory.{v} C] [category.{v'} D] : category (C ⥤ D) :=
begin
  apply category.mk, intros F G, fapply adjointify,
  { exact functor_isotoid },
  { intro i, apply hom_eq_to_iso_eq, apply nat_trans_eq, apply eq_of_homotopy, intro c,
    rwr functor_idtoiso_comp,
    change (idtoiso (@apd10 _ _ F.obj G.obj (ap functor.obj (functor_eq _ _ _ _)) c)).hom = _,
    rwr functor_eq_obj, rwr homotopy_eq_rinv,
    change (idtoiso (idtoiso⁻¹ᶠ (functor_iso_to_isos i c))).hom = _,
    rwr category.idtoiso_rinv },
  { intro p, hinduction p, rwr idtoiso_refl_eq, change functor_eq C D _ _ = idp,
    rwr <- functor_eq_idp, fapply apd011 (functor_eq C D),
    { change eq_of_homotopy (λ (c : C), category.isotoid
                               (@functor_iso_to_isos C _ _ _ _ _  (id_is_iso F) c)) = idpath _,
      rwr <- eq_of_homotopy_idp, apply ap eq_of_homotopy, apply eq_of_homotopy, intro c,
      change category.isotoid (functor_iso_to_isos (id_is_iso F) c) = idpath (F.obj c),
      rwr functor_isoid_to_isoids, rwr isotoid_id_refl },
    { apply pathover_of_tr_eq, exact is_prop.elim _ _ } }
end

/- Whiskering of natural transformations with functors: [HoTT-Book, Def.9.2.7] -/
@[hott]
def tr_whisk_l [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  {F : D ⥤ E} {G : D ⥤ E} (H : C ⥤ D) (α : F ⟶ G) : H ⋙ F ⟶ H ⋙ G :=
begin
  fapply nat_trans.mk,
  { intro c, exact α.app (H.obj c) },
  { intros c c' f,
    change F.map (H.map f) ≫ α.app (H.obj c') = α.app (H.obj c) ≫ G.map (H.map f),
    rwr α.naturality }
end

@[hott]
def tr_whisk_l_id [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  (H : C ⥤ D) (F : D ⥤ E) : tr_whisk_l H (𝟙 F) = 𝟙 (H ⋙ F) :=
begin apply nat_trans_eq, apply eq_of_homotopy, intro c, exact idp end

@[hott]
def tr_whisk_r [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  {F : C ⥤ D} {G : C ⥤ D} (α : F ⟶ G) (H : D ⥤ E) : F ⋙ H ⟶ G ⋙ H :=
begin
  fapply nat_trans.mk,
  { intro c, exact H.map (α.app c) },
  { intros c c' f,
    change H.map (F.map f) ≫ H.map (α.app c') = H.map (α.app c) ≫ H.map (G.map f),
    rwr <- H.map_comp, rwr <- H.map_comp, rwr α.naturality }
end

@[hott]
def tr_whisk_r_id [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  (F : C ⥤ D) (H : D ⥤ E) : tr_whisk_r (𝟙 F) H = 𝟙 (F ⋙ H) :=
begin
  apply nat_trans_eq, apply eq_of_homotopy, intro c,
  change H.map (𝟙 (F.obj c)) = 𝟙 (H.obj (F.obj c)),
  rwr functor.map_id
end

/- Horizontal composition of natural transformations can be defined in two ways that
   are (propositionally) equal [HoTT-Book, Lem.9.2.8]. -/
@[hott]
def horiz_comp_eq [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  {F : C ⥤ D} {G : C ⥤ D} {H : D ⥤ E} {K : D ⥤ E} (γ : F ⟶ G) (δ : H ⟶ K) :
  tr_whisk_r γ H ≫ tr_whisk_l G δ = tr_whisk_l F δ ≫ tr_whisk_r γ K :=
begin
  apply nat_trans_eq, apply eq_of_homotopy, intro c,
  change H.map (γ.app c) ≫ δ.app (G.obj c) = δ.app (F.obj c) ≫ K.map (γ.app c),
  rwr δ.naturality
end

/- The composition of functors has left and right neutral and is associative.
   We construct these equalities from natural isomorphisms. -/
@[hott, reducible]
def l_neutral_funct_iso [precategory.{v} C] [precategory.{v'} D] (F : C ⥤ D) :
  (id_functor C ⋙ F) ≅ F :=
begin
  fapply iso.mk,
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (F.obj c) },
    { intros c c' f, hsimp } },
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (F.obj c) },
    { intros c c' f, hsimp } },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp }
end

@[hott]
def l_neutral_funct [precategory.{v} C] [category.{v'} D] (F : C ⥤ D) :
  (id_functor C ⋙ F) = F :=
category.isotoid (l_neutral_funct_iso F)

@[hott, reducible]
def r_neutral_funct_iso [precategory.{v} C] [precategory.{v'} D] (F : C ⥤ D) :
  (F ⋙ id_functor D) ≅ F :=
begin
  fapply iso.mk,
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (F.obj c) },
    { intros c c' f, hsimp } },
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (F.obj c) },
    { intros c c' f, hsimp } },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp }
end

@[hott]
def r_neutral_funct [precategory.{v} C] [category.{v'} D] (F : C ⥤ D) :
  (F ⋙ id_functor D) = F :=
category.isotoid (r_neutral_funct_iso F)

@[hott, reducible]
def assoc_funct_iso [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  [precategory.{v'''} F] (G : C ⥤ D) (H : D ⥤ E) (I : E ⥤ F) :
  ((G ⋙ H) ⋙ I) ≅ (G ⋙ (H ⋙ I)) :=
begin
  fapply iso.mk,
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (I.obj (H.obj (G.obj c))) },
    { intros c c' f, hsimp } },
  { fapply nat_trans.mk,
    { intro c, exact 𝟙 (I.obj (H.obj (G.obj c))) },
    { intros c c' f, hsimp } },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp },
  { apply nat_trans_eq, apply eq_of_homotopy, intro c,
    change (nat_trans.mk _ _).app c ≫ (nat_trans.mk _ _).app c = _, hsimp, exact idp }
end

@[hott]
def assoc_funct [precategory.{v} C] [precategory.{v'} D] [precategory.{v''} E]
  [category.{v'''} F] (G : C ⥤ D) (H : D ⥤ E) (I : E ⥤ F) :
  ((G ⋙ H) ⋙ I) = (G ⋙ (H ⋙ I)) :=
category.isotoid (assoc_funct_iso G H I)

/- The power set `𝒫 A` of a set `A` is a precategory, with inclusions of
   subsets as morphisms. -/
@[hott, instance]
def power_set_has_hom {A : Set} : has_hom (𝒫 A) :=
  has_hom.mk (λ U V : Subset A, Prop_to_Set (to_Prop (U ⊆ V)))
  /- I am not sure whether coercions from `Type` to `Prop` and `Prop` to
    `Set` are a good idea. They may introduce circuitious coercions. -/

@[hott]
instance inc_hom {A : Set} (B C : 𝒫 A) : has_coe ↥(B ⊆ C) ↥(B ⟶ C) :=
  ⟨λ inc, inc⟩

@[hott]
def power_set_unique_hom {A : Set} {B C : 𝒫 A} (f g : B ⟶ C) : f = g :=
  @is_prop.elim _ (is_prop_subset B C) f g

@[hott, instance]
def power_set_cat_struct {A : Set} : category_struct (𝒫 A) :=
  category_struct.mk subset_refl subset_trans

@[hott, instance]
def power_set_precat {A : Set} : precategory (𝒫 A) :=
  have id_comp : ∀ (B C : 𝒫 A) (f : B ⟶ C), 𝟙 B ≫ f = f, from
    assume B C f, power_set_unique_hom _ _,
  have comp_id : ∀ (B C : 𝒫 A) (f : B ⟶ C), f ≫ 𝟙 C = f, from
    assume B C f, power_set_unique_hom _ _,
  have assoc   : ∀ (B C D E : 𝒫 A) (f : B ⟶ C) (g : C ⟶ D) (h : D ⟶ E),
                    (f ≫ g) ≫ h = f ≫ (g ≫ h), from
    assume B C D E f g h, power_set_unique_hom _ _,
  precategory.mk id_comp comp_id assoc

/- Every subset of a set that is a (small?) precategory is a
   (full sub-)precategory. -/
@[hott, instance]
def subset_precat_has_hom {A : Set.{u}} [hA : has_hom.{v} A] (B : Subset A) :
  has_hom ↥B :=
has_hom.mk (λ x y : ↥B, @has_hom.hom _ hA x y)

@[hott, instance]
def subset_precat_cat_struct {A : Set.{u}} [hA : category_struct.{v} A]
  (B : Subset A) : category_struct ↥B :=
category_struct.mk (λ b : ↥B, @category_struct.id _ hA ↑b)
  (λ (b c d : ↥B) (f : b ⟶ c) (g : c ⟶ d),
        @category_struct.comp _ hA ↑b ↑c ↑d f g)

@[hott, instance]
def subset_precat_precat {A : Set.{u}} [hA : precategory.{v} A]
  (B : Subset A) : precategory ↥B :=
precategory.mk (λ (b c : ↥B) (f : b ⟶ c), precategory.id_comp f)
               (λ (b c : ↥B) (f : b ⟶ c), precategory.comp_id f)
               (λ (b c d e: ↥B) (f : b ⟶ c) (g : c ⟶ d) (h : d ⟶ e),
                  precategory.assoc f g h)

/- The inclusion of two subsets of a set that is a precategory defines a functor between the
   underlying sets.

   We need two equalities easily shown by induction. -/
@[hott]
def tr_tr_cat_id {C : Type u} [precategory.{v} C] {c c' : C} (p : c = c') :
  p ▸[λ d, c' ⟶ d] (p ▸[λ d, d ⟶ c] 𝟙 c) = 𝟙 c' :=
begin hinduction p, refl end

@[hott]
def tr_tr_cat_comp {C : Type u} [precategory.{v} C] {c₁ c₁' c₂ c₂' c₃ c₃': C} (p : c₁ = c₁')
  (q : c₂ = c₂') (r : c₃ = c₃') (f : c₁' ⟶ c₂') (g : c₂' ⟶ c₃') :
  r ▸[λ d, c₁' ⟶ d] (p ▸[λ d, d ⟶ c₃] ((p⁻¹ ▸[λ d, d ⟶ c₂] (q⁻¹ ▸[λ d, c₁' ⟶ d] f)) ≫
                                         (q⁻¹ ▸[λ d, d ⟶ c₃] (r⁻¹ ▸[λ d, c₂' ⟶ d] g)))) = f ≫ g :=
begin hinduction p, hinduction q, hinduction r, refl end

@[hott]
def functor_subsets_precat {A : Set.{u}} [hA : precategory.{v} A] {B C : Subset A}
  (inc : B ⊆ C) : ↥B ⥤ ↥C :=
begin
  fapply functor.mk,
  { intro b, exact ⟨b.1, inc b.1 b.2⟩ },
  { intros b b' f, exact f },
  { intro b, refl },
  { intros b₁ b₂ b₃ f g, refl }
end

/- `Set.{u}` is a category - the category of `Type u`-small sets. -/
@[hott, instance]
def set_has_hom : has_hom Set.{u} :=
  has_hom.mk (λ A B : Set.{u}, Set.mk (A -> B) (@is_set_map A B))

@[hott, instance]
def set_cat_struct : category_struct Set.{u} :=
  category_struct.mk (λ A : Set.{u}, id_map A)
                     (λ (A B C: Set.{u}) (f : A ⟶ B) (g : B ⟶ C), g ∘ f)

@[hott, instance]
def Set_precategory : precategory Set.{u} :=
  have ic : Π (A B : Set.{u}) (f : A ⟶ B), 𝟙 A ≫ f = f, from
    assume A B f, by refl,
  have ci : Π (A B : Set.{u}) (f : A ⟶ B), f ≫ 𝟙 B = f, from
    assume A B f, by refl,
  have as : Π (A B C D : Set.{u}) (f : A ⟶ B) (g : B ⟶ C) (h : C ⟶ D),
             (f ≫ g) ≫ h = f ≫ (g ≫ h), from
    assume A B C D f g h, by refl,
  precategory.mk ic ci as

@[hott, hsimp]
def Set_isotocareqv {A B : Set.{u}} : (A ≅ B) -> (A ≃ B) :=
    assume i,
  have eqv_iso : is_equiv i.hom, from
    have r_inv : ∀ b : B, i.hom (i.inv b) = b, from
      assume b, homotopy_of_eq i.r_inv b,
    have l_inv : ∀ a : A, i.inv (i.hom a) = a, from
      assume a, homotopy_of_eq i.l_inv a,
    adjointify i.hom i.inv r_inv l_inv,
  equiv.mk i.hom eqv_iso

@[hott, hsimp, reducible]
def Set_isotoid {A B : Set.{u}} : (A ≅ B) -> (A = B) :=
  assume i,
  car_eq_to_set_eq (ua (Set_isotocareqv i))

@[hott, hsimp]
def Set_idtoiso_hom_eq {A B : Set.{u}} (p : A = B) :
  ∀ a : A, ((idtoiso p).hom : A -> B) a = p ▸ a :=
begin
  hinduction p, rwr idtoiso_refl_eq, hsimp,
  intro a, refl
end

@[hott, hsimp]
def Set_isotoid_eq_hom {A B : Set.{u}} (i : A ≅ B) :
  ∀ a : A.carrier, (Set_isotoid i) ▸[λ A : Set.{u}, A.carrier] a = i.hom a :=
assume a,
calc (Set_isotoid i) ▸ a = ((ap (trunctype.carrier) (Set_isotoid i)) ▸[λ A : Type u, A] a) :
           (tr_ap (λ A : Type u, A) (trunctype.carrier) _ a)⁻¹
     ... = ((set_eq_to_car_eq (Set_isotoid i)) ▸[λ A : Type u, A] a) :
           rfl
     ... = ((ua (Set_isotocareqv i)) ▸[λ A : Type u, A] a) :
           by rwr rinv_set_eq_car_eq _
     ... = (equiv_of_eq (ua (Set_isotocareqv i))).to_fun a : cast_def _ _
     ... = i.hom a : cast_ua (Set_isotocareqv i) a

@[hott, hsimp]
def Set_isotoid_eq_refl {A : Set.{u}} : Set_isotoid (id_is_iso A) = refl A :=
  calc Set_isotoid (id_is_iso A) = car_eq_to_set_eq (ua (equiv.refl ↥A)) : rfl
       ... = car_eq_to_set_eq (idpath ↥A) : by rwr ua_refl
       ... = refl A : idp_car_to_idp_set

@[hott]
def Set_id_iso_rinv {A B : Set.{u}} : ∀ i : A ≅ B, idtoiso (Set_isotoid i) = i :=
  assume i,
  have hom_eq : ∀ a : A, ((idtoiso (Set_isotoid i)).hom : A -> B) a = i.hom a, from
    assume a, (Set_idtoiso_hom_eq (Set_isotoid i) a) ⬝ Set_isotoid_eq_hom i a,
  hom_eq_to_iso_eq (eq_of_homotopy hom_eq)

@[hott]
def Set_id_iso_linv {A B : Set.{u}} : ∀ p : A = B, Set_isotoid (idtoiso p) = p :=
begin
  intro p, hinduction p,
  rwr idtoiso_refl_eq, exact Set_isotoid_eq_refl
end

@[hott, instance]
def Set_category : category Set.{u} :=
  have ideqviso : ∀ A B : Set.{u}, is_equiv (@idtoiso _ _ A B), from assume A B,
    adjointify idtoiso Set_isotoid Set_id_iso_rinv Set_id_iso_linv,
  category.mk ideqviso

/- The subobjects of an object, together with their monomorphism-preserving homomorphisms
   defined in [categories.basic], form a category. -/
@[hott, instance]
def subobject_has_hom {C : Type u} [category.{v} C] {c : C} : has_hom (subobject c) :=
  has_hom.mk (λ a b : subobject c, Set.mk (subobject_hom a b) (is_trunc_succ _ -1))

@[hott]
def id_subobject {C : Type u} [category.{v} C] {c : C} (a : subobject c) : subobject_hom a a :=
  begin fapply hom_of_monos.mk a.is_mono a.is_mono, exact 𝟙 a.obj, hsimp end

@[hott]
def comp_subobject {C : Type u} [category.{v} C] {c : C} (a₁ a₂ a₃ : subobject c) :
  subobject_hom a₁ a₂ -> subobject_hom a₂ a₃ -> subobject_hom a₁ a₃ :=
begin
  intros f g, fapply hom_of_monos.mk a₁.is_mono a₃.is_mono, exact f.hom_obj ≫ g.hom_obj,
  rwr precategory.assoc, rwr g.fac, rwr f.fac
end

@[hott, instance]
def subobject_cat_struct {C : Type u} [category.{v} C] {c : C} :
  category_struct (subobject c) :=
category_struct.mk id_subobject comp_subobject

@[hott, instance]
def subobject_precategory {C : Type u} [category.{v} C] {c : C} :
  precategory (subobject c) :=
have ic : Π (a b : subobject c) (f : a ⟶ b), 𝟙 a ≫ f = f, from
  assume a b f, by exact is_prop.elim _ _,
have ci : Π (a b : subobject c) (f : a ⟶ b), f ≫ 𝟙 b = f, from
  assume a b f, by exact is_prop.elim _ _,
have as : Π (a₁ a₂ a₃ a₄ : subobject c) (f : a₁ ⟶ a₂) (g : a₂ ⟶ a₃) (h : a₃ ⟶ a₄),
             (f ≫ g) ≫ h = f ≫ (g ≫ h), from
  assume a₁ a₂ a₃ a₄ f g h, by exact is_prop.elim _ _,
precategory.mk ic ci as

@[hott]
def iso_of_monos_to_iso {C : Type u} [category.{v} C] {c : C} (a b : subobject c) :
  (iso_of_monos a.is_mono b.is_mono) -> (a ≅ b) :=
begin
  intro im, fapply iso.mk,
  { fapply hom_of_monos.mk, exact im.iso_obj.hom, exact im.fac },
  { fapply hom_of_monos.mk, exact im.iso_obj.inv, apply eq.inverse, apply iso_move_lr,
    exact im.fac },
  exact is_prop.elim _ _, exact is_prop.elim _ _
end

@[hott]
def iso_to_iso_of_monos {C : Type u} [category.{v} C] {c : C} (a b : subobject c) :
  (a ≅ b) -> (iso_of_monos a.is_mono b.is_mono) :=
begin
  intro i, fapply iso_of_monos.mk,
  { fapply iso.mk, exact i.hom.hom_obj, exact i.inv.hom_obj,
    exact ap hom_of_monos.hom_obj i.r_inv, exact ap hom_of_monos.hom_obj i.l_inv },
  { exact i.hom.fac }
end

@[hott]
def iso_of_monos_eqv_iso {C : Type u} [category.{v} C] {c : C} (a b : subobject c) :
  (iso_of_monos a.is_mono b.is_mono) ≃ (a ≅ b) :=
begin
  fapply equiv.mk,
  { exact iso_of_monos_to_iso a b },
  { fapply adjointify,
    { exact iso_to_iso_of_monos a b },
    { intro i, apply hom_eq_to_iso_eq, exact is_prop.elim _ _ },
    { intro i, exact is_prop.elim _ _ } }
end

@[hott]
def subobj_idtoiso {C : Type u} [category.{v} C] {c : C} (a b : subobject c) :
  @idtoiso _ _ a b = (iso_of_monos_eqv_iso a b).to_fun ∘
                     (equal_subobj_eqv_iso_mono a b).to_fun :=
begin apply eq_of_homotopy, intro p, apply hom_eq_to_iso_eq, exact is_prop.elim _ _ end

@[hott, instance]
def subobject_category {C : Type u} [category.{v} C] {c : C} :
  category (subobject c) :=
begin apply category.mk, intros a b, rwr subobj_idtoiso a b, apply_instance end

@[hott]
def subobj_antisymm {C : Type u} [category.{v} C] {c : C} (a b : subobject c) :
  (a ⟶ b) -> (b ⟶ a) -> (a = b) :=
begin
  intros i j ,
  have iso_ab : a ≅ b, from
    begin fapply iso.mk, exact i, exact j, exact is_prop.elim _ _, exact is_prop.elim _ _ end,
  exact category.isotoid iso_ab
end

@[hott]
def subobj_trans {C : Type u} [category.{v} C] {c : C} (a : subobject c)
  (b : subobject a.obj) : subobject c :=
subobject.mk b.obj (b.hom ≫ a.hom) (is_mono_is_trans b.is_mono a.is_mono)

/- The category of subobjects always has a top element. -/
@[hott]
def top_subobject {C : Type u} [category.{v} C] (c : C) : subobject c :=
  subobject.mk c (𝟙 c) (isos_are_mono (id_is_iso c))

@[hott]
def top_subobj_prop {C : Type u} [category.{v} C] {c : C} :
  Π (a : subobject c), a ⟶ top_subobject c :=
begin intro a, fapply hom_of_monos.mk, exact a.hom, hsimp end

/- We can define images of homomorphisms as subobjects of their codomain satisfying a
   minimal property. Note that the factoring homomorphism is unique as the inclusion
   homomorphism is a monomorphism. -/
@[hott]
structure cat_image {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) :=
  (subobj : subobject d)
  (fac : Σ f' : c ⟶ subobj.obj, f' ≫ subobj.hom = f)
  (univ : Π (a : subobject d), (Σ f' : c ⟶ a.obj, f' ≫ a.hom = f) -> (subobj ⟶ a))

@[hott]
def subobject_fac_is_unique {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d)
  (a : subobject d) : Π fac₁ fac₂ : (Σ (f' : c ⟶ a.obj), f' ≫ a.hom = f), fac₁ = fac₂ :=
begin
  intros fac₁ fac₂, fapply sigma.sigma_eq,
  { fapply a.is_mono, exact fac₁.2 ⬝ fac₂.2⁻¹ },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ }
end

@[hott, instance]
def subobject_fac_is_prop {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d)
  (a : subobject d) : is_prop (Σ f' : c ⟶ a.obj, f' ≫ a.hom = f) :=
is_prop.mk (subobject_fac_is_unique f a)

@[hott]
class has_image {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) :=
  (exists_im : ∥cat_image f∥)

@[hott]
def cat_image_is_unique {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) :
  Π im₁ im₂ : cat_image f, im₁ = im₂ :=
begin
  intros im₁ im₂,
  hinduction im₁ with subobj₁ fac₁ univ₁, hinduction im₂ with subobj₂ fac₂ univ₂,
  fapply apdd2 cat_image.mk,
  { fapply subobj_antisymm, exact univ₁ subobj₂ fac₂, exact univ₂ subobj₁ fac₁ },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ },
  { apply pathover_of_tr_eq, exact is_prop.elim _ _ }
end

@[hott, instance]
def cat_image_is_prop {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) :
  is_prop (cat_image f) :=
is_prop.mk (cat_image_is_unique f)

@[hott, reducible]
def hom.image {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) [has_image f] :
  subobject d :=
(untrunc_of_is_trunc (has_image.exists_im f)).subobj

@[hott, reducible]
def hom_to_image {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) [has_image f] :
  c ⟶ (hom.image f).obj :=
(untrunc_of_is_trunc (has_image.exists_im f)).fac.1

@[hott]
def hom_to_image_eq {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) [has_image f] :
  hom_to_image f ≫ (hom.image f).hom = f :=
(untrunc_of_is_trunc (has_image.exists_im f)).fac.2

@[hott]
def hom_image_univ {C : Type u} [category.{v} C] {c d : C} (f : c ⟶ d) [has_image f] :
  Π (a : subobject d) (f' : c ⟶ a.obj), f' ≫ a.hom = f -> (hom.image f ⟶ a) :=
assume a f' p, (untrunc_of_is_trunc (has_image.exists_im f)).univ a ⟨f', p⟩

@[hott, instance]
def subobj_has_im {C : Type u} [category.{v} C] {c : C} (b : subobject c) :
  has_image b.hom :=
have im_b : cat_image b.hom, from
  cat_image.mk b (sigma.mk (𝟙 b.obj) (precategory.id_comp b.hom))
               (λ a m, hom_of_monos.mk _ _ m.1 m.2),
has_image.mk (tr im_b)

@[hott]
def subobj_is_im {C : Type u} [category.{v} C] {c : C} (b : subobject c) :
  hom.image b.hom = b := idp

@[hott]
def im_incl {C : Type u} [category.{v} C] {a b c : C} (f : a ⟶ b) (g : b ⟶ c)
  [has_image (f ≫ g)] [has_image g] : hom.image (f ≫ g) ⟶ hom.image g :=
begin
  fapply cat_image.univ, fapply sigma.mk,
  { exact f ≫ hom_to_image g },
  { rwr precategory.assoc, rwr hom_to_image_eq g }
end

@[hott]
class has_images (C : Type u) [category.{v} C] :=
  (has_im : Π {c d : C} (f : c ⟶ d), has_image f)

@[hott, instance]
def has_image_of_has_images {C : Type u} [category.{v} C] [has_images C] {c d : C}
  (f : c ⟶ d) : has_image f :=
has_images.has_im f

end categories

end hott


import Z.Util

/- TODO: remove duplicates?  -/

def Environment (R: Type u) := R

/--
`IsComponent A B` means that a permutation of `A` is part of `B`.

Symbolic form: A ∣ B.

For example if `A = A₁ × A₂` then
```
A ∣ (B₁ × A₁ × B₂ × A₂)
A ∣ (A₁ × B₁ × B₂ × A₂)
A ∣ (A₁ × A₂ × B₁ × B₂)
A ∣ (A₂ × A₁ × B₁ × B₂)
...
```
all are valid.

`Unit` is assumed to be part of any product.

- `get: B -> A` is the projection.
-/
class IsComponent (A : Type u) (B: Type v) where
  get: B -> A

infixl:65 " ∣ " => IsComponent

namespace IsComponent

  def contramap [component: A ∣ B] (f: A -> C): C ∣ B :=
    ⟨get ∘> f⟩

  /--
  This will detect permutations of `A × B` in `H × T`.

  If we reach this case then we know that `A ≠ H` (as this is covered by `rule4`).

  So we need to things:
  - `A` is in `T`
  - `B` is in `H × T`

  -/
  instance rule5 [A ∣ T] [B ∣ (H × T)] : (A × B) ∣ (H × T) where
    get | (h, t) => (get t, get (h, t))

  /-- Same heads and different tails but one tail is a component of the other -/
  instance rule4 [B ∣ T] : (A × B) ∣ (A × T) where
    get | (a, t) => (a, get t)

  /- Either A is in the head or the tail -/
  instance rule3 [A ∣ T] : A ∣ (H × T) := ⟨fun (_, t) => get t⟩
  instance rule2         : A ∣ (A × T) := ⟨fun (a, _) => a⟩

  /-- A few base cases  -/
  instance rule1 :    L ∣ L := ⟨id⟩
  instance rule0 : Unit ∣ L := ⟨fun _ => ()⟩

end IsComponent

namespace IsComponentExamples
  def accept [R1 ∣ R2] (_: Environment R1) (_: Environment R2) := true

  /- Base cases -/
  example: accept () () = true := rfl
  example: accept () ('c', "a", 1) = true := rfl

  /- equal elements -/
  example: accept 'c' 'c' = true := rfl
  example: accept ("a", 1) ("a", 1) = true := rfl
  example: accept ('c', "a", 1) ('c', "a", 1) = true := rfl

  /- more elements provided than required -/
  example: accept 'c' ('c', "a", 1, true) = true := rfl
  example: accept ('c', "a", 1) ('c', "a", 1, true) = true := rfl

  -- negative:
  #check_failure accept ('c', "a", 1, true) ('c', "a", 1)

  /- Other rules -/
  example: accept ("a", 1) ('c', "a", 1) = true := rfl
  example: accept (1, "a") ('c', "a", 1) = true := rfl
  example: accept "a"      ('c', "a", 1) = true := rfl
  example: accept ("a", 'c', 1) ('c', "a", 1) = true := rfl

  #check_failure accept (1, "a", 'c') (true, 1)
  #check_failure accept ('c', "a", 1) []

end IsComponentExamples

namespace Environment

  def EmptyEnv: Type := Environment Unit

  def empty: EmptyEnv :=
    ()

  def EmptyEnv.add (self: EmptyEnv) (a: A) : Environment A := a

  def add (self: Environment T) (a: A) : Environment (A × T) :=
    ⟨a, self⟩

  def concat (self: Environment T) (ea: Environment A) : Environment (A × T) :=
    ⟨ea, self⟩

  def get (self: Environment T) (A) [component: A ∣ T] : A :=
    component.get self

  def of (a: A) : Environment A :=
    empty.add a

  def map (f: A -> B): Environment A -> Environment B := f

  infixr:67 " ++ " => concat

end Environment

namespace EnvExamples
  open Environment

  example : get 'c'               Char = 'c' := rfl
  example : get ('c', "a", 1) Char = 'c' := rfl
  example : get ('c', "a", 1)  Nat = 1   := rfl
  example : get ('c', "a", 1) Unit = ()  := rfl

  example : get ('c', "a", 1, "b") String = "a" := rfl

  #check_failure get ('c', "a", 1) Int

  -- Order does not matter
  example : get ('c', "a", 1, "b") (String × Nat) = ("a", 1) := rfl
  example : get ('c', "a", 1, "b") (Nat × String) = (1, "a") := rfl

  -- Note that only the first String "a" is picked up.
  example : get ('c', "a", 1, "b") (Char × String) = ('c', "a") := rfl

  -- Make it a Type 1 on purpose to verify that an Environment can hold types on different universes

  structure Point: Type 1 := (x y: Nat) deriving Repr, BEq

  def p := Point.mk 1 2

  def e0: EmptyEnv                     := empty
  def e1: Environment String           := e0.add "<secret>"
  def e2: Environment (Point × String) := e1.add p

  example : e1.get String = "<secret>" := rfl
  example : e2.get String = "<secret>" := rfl
  example : e2.get Point  = p          := rfl

  #check_failure e2.get Int

end EnvExamples


/-
Copyright (c) 2021 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Andrew Yang
-/
import algebra.homology.exact
import category_theory.preadditive.additive_functor

/-!
# Short exact sequences, and splittings.

`short_exact f g` is the proposition that `0 ⟶ A -f⟶ B -g⟶ C ⟶ 0` is an exact sequence.

We define when a short exact sequence is left-split, right-split, and split.

## See also
In `algebra.homology.short_exact.abelian` we show that in an abelian category
a left-split short exact sequences admits a splitting.
-/

noncomputable theory

open category_theory category_theory.limits category_theory.preadditive

variables {𝒜 : Type*} [category 𝒜]

namespace category_theory
variables {A B C A' B' C' : 𝒜} (f : A ⟶ B) (g : B ⟶ C) (f' : A' ⟶ B') (g' : B' ⟶ C')

section has_zero_morphisms
variables [has_zero_morphisms 𝒜] [has_kernels 𝒜] [has_images 𝒜]

/-- If `f : A ⟶ B` and `g : B ⟶ C` then `short_exact f g` is the proposition saying
  the resulting diagram `0 ⟶ A ⟶ B ⟶ C ⟶ 0` is an exact sequence. -/
structure short_exact : Prop :=
[mono  : mono f]
[epi   : epi g]
(exact : exact f g)

/-- An exact sequence `A -f⟶ B -g⟶ C` is *left split*
if there exists a morphism `φ : B ⟶ A` such that `f ≫ φ = 𝟙 A` and `g` is epi.

Such a sequence is automatically short exact (i.e., `f` is mono). -/
structure left_split : Prop :=
(left_split : ∃ φ : B ⟶ A, f ≫ φ = 𝟙 A)
[epi   : epi g]
(exact : exact f g)

lemma left_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : left_split f g) : short_exact f g :=
{ mono :=
  begin
    obtain ⟨φ, hφ⟩ := h.left_split,
    haveI : mono (f ≫ φ) := by { rw hφ, apply_instance },
    exact mono_of_mono f φ,
  end,
  epi := h.epi,
  exact := h.exact }

/-- An exact sequence `A -f⟶ B -g⟶ C` is *right split*
if there exists a morphism `φ : C ⟶ B` such that `f ≫ φ = 𝟙 A` and `f` is mono.

Such a sequence is automatically short exact (i.e., `g` is epi). -/
structure right_split : Prop :=
(right_split : ∃ χ : C ⟶ B, χ ≫ g = 𝟙 C)
[mono  : mono f]
(exact : exact f g)

lemma right_split.short_exact {f : A ⟶ B} {g : B ⟶ C} (h : right_split f g) : short_exact f g :=
{ epi :=
  begin
    obtain ⟨χ, hχ⟩ := h.right_split,
    haveI : epi (χ ≫ g) := by { rw hχ, apply_instance },
    exact epi_of_epi χ g,
  end,
  mono := h.mono,
  exact := h.exact }

end has_zero_morphisms

section preadditive
variables [preadditive 𝒜]

/-- An exact sequence `A -f⟶ B -g⟶ C` is *split* if there exist
`φ : B ⟶ A` and `χ : C ⟶ B` such that:
* `f ≫ φ = 𝟙 A`
* `χ ≫ g = 𝟙 C`
* `f ≫ g = 0`
* `χ ≫ φ = 0`
* `φ ≫ f + g ≫ χ = 𝟙 B`

Such a sequence is automatically short exact (i.e., `f` is mono and `g` is epi). -/
structure split : Prop :=
(split : ∃ (φ : B ⟶ A) (χ : C ⟶ B),
  f ≫ φ = 𝟙 A ∧ χ ≫ g = 𝟙 C ∧ f ≫ g = 0 ∧ χ ≫ φ = 0 ∧ φ ≫ f + g ≫ χ = 𝟙 B)

variables [has_kernels 𝒜] [has_images 𝒜]

lemma exact_of_split {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C} {χ : C ⟶ B} {φ : B ⟶ A}
  (hfg : f ≫ g = 0) (H : φ ≫ f + g ≫ χ = 𝟙 B) : exact f g :=
{ w := hfg,
  epi :=
  begin
    let ψ : (kernel_subobject g : 𝒜) ⟶ image_subobject f :=
      subobject.arrow _ ≫ φ ≫ factor_thru_image_subobject f,
    suffices : ψ ≫ image_to_kernel f g hfg = 𝟙 _,
    { convert epi_of_epi ψ _, rw this, apply_instance },
    rw ← cancel_mono (subobject.arrow _), swap, { apply_instance },
    simp only [image_to_kernel_arrow, image_subobject_arrow_comp, category.id_comp, category.assoc],
    calc (kernel_subobject g).arrow ≫ φ ≫ f
        = (kernel_subobject g).arrow ≫ 𝟙 B : _
    ... = (kernel_subobject g).arrow        : category.comp_id _,
    rw [← H, preadditive.comp_add],
    simp only [add_zero, zero_comp, kernel_subobject_arrow_comp_assoc],
  end }

section

variables {f g}

lemma split.exact (h : split f g) : exact f g :=
by { obtain ⟨φ, χ, -, -, h1, -, h2⟩ := h, exact exact_of_split h1 h2 }

lemma split.left_split (h : split f g) : left_split f g :=
{ left_split := by { obtain ⟨φ, χ, h1, -⟩ := h, exact ⟨φ, h1⟩, },
  epi := begin
    obtain ⟨φ, χ, -, h2, -⟩ := h,
    have : epi (χ ≫ g), { rw h2, apply_instance },
    exactI epi_of_epi χ g,
  end,
  exact := h.exact }

lemma split.right_split (h : split f g) : right_split f g :=
{ right_split := by { obtain ⟨φ, χ, -, h1, -⟩ := h, exact ⟨χ, h1⟩, },
  mono := begin
    obtain ⟨φ, χ, h1, -⟩ := h,
    have : mono (f ≫ φ), { rw h1, apply_instance },
    exactI mono_of_mono f φ,
  end,
  exact := h.exact }

lemma split.short_exact (h : split f g) : short_exact f g :=
h.left_split.short_exact

end

lemma split.map {𝒜 ℬ : Type*} [category 𝒜] [preadditive 𝒜] [category ℬ] [preadditive ℬ]
  (F : 𝒜 ⥤ ℬ) [functor.additive F] {A B C : 𝒜} {f : A ⟶ B} {g : B ⟶ C} (h : split f g) :
  split (F.map f) (F.map g) :=
begin
  obtain ⟨φ, χ, h1, h2, h3, h4, h5⟩ := h,
  refine ⟨⟨F.map φ, F.map χ, _⟩⟩,
  simp only [← F.map_comp, ← F.map_id, ← F.map_add, F.map_zero, *, eq_self_iff_true, and_true],
end

/-- The sequence `A ⟶ A ⊞ B ⟶ B` is exact. -/
lemma exact_inl_snd [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inl : A ⟶ A ⊞ B) biprod.snd :=
exact_of_split biprod.inl_snd biprod.total

/-- The sequence `B ⟶ A ⊞ B ⟶ A` is exact. -/
lemma exact_inr_fst [has_binary_biproducts 𝒜] (A B : 𝒜) :
  exact (biprod.inr : B ⟶ A ⊞ B) biprod.fst :=
exact_of_split biprod.inr_fst ((add_comm _ _).trans biprod.total)

end preadditive

/-- A *splitting* of a sequence `A -f⟶ B -g⟶ C` is an isomorphism
to the short exact sequence `0 ⟶ A ⟶ A ⊞ C ⟶ C ⟶ 0` such that
the vertical maps on the left and the right are the identity. -/
@[nolint has_nonempty_instance]
structure splitting [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜] :=
(iso : B ≅ A ⊞ C)
(comp_iso_eq_inl : f ≫ iso.hom = biprod.inl)
(iso_comp_snd_eq : iso.hom ≫ biprod.snd = g)

variables {f g}

namespace splitting

section has_zero_morphisms
variables [has_zero_morphisms 𝒜] [has_binary_biproducts 𝒜]

attribute [simp, reassoc] comp_iso_eq_inl iso_comp_snd_eq

variables (h : splitting f g)

@[simp, reassoc] lemma inl_comp_iso_eq : biprod.inl ≫ h.iso.inv = f :=
by rw [iso.comp_inv_eq, h.comp_iso_eq_inl]

@[simp, reassoc] lemma iso_comp_eq_snd : h.iso.inv ≫ g = biprod.snd :=
by rw [iso.inv_comp_eq, h.iso_comp_snd_eq]

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.section : C ⟶ B` is the morphism satisfying `h.section ≫ g = 𝟙 C`. -/
def _root_.category_theory.splitting.section : C ⟶ B := biprod.inr ≫ h.iso.inv

/-- If `h` is a splitting of `A -f⟶ B -g⟶ C`,
then `h.retraction : B ⟶ A` is the morphism satisfying `f ≫ h.retraction = 𝟙 A`. -/
def retraction : B ⟶ A := h.iso.hom ≫ biprod.fst

@[simp, reassoc] lemma section_π : h.section ≫ g = 𝟙 C := by { delta splitting.section, simp }

@[simp, reassoc] lemma ι_retraction : f ≫ h.retraction = 𝟙 A := by { delta retraction, simp }

@[simp, reassoc] lemma section_retraction : h.section ≫ h.retraction = 0 :=
by { delta splitting.section retraction, simp }

/-- The retraction in a splitting is a split mono. -/
protected def split_mono : split_mono f := ⟨h.retraction, by simp⟩

/-- The section in a splitting is a split epi. -/
protected def split_epi : split_epi g := ⟨h.section, by simp⟩

@[simp, reassoc] lemma inr_iso_inv : biprod.inr ≫ h.iso.inv = h.section := rfl

@[simp, reassoc] lemma iso_hom_fst : h.iso.hom ≫ biprod.fst = h.retraction := rfl

/-- A short exact sequence of the form `X -f⟶ Y -0⟶ Z` where `f` is an iso and `Z` is zero
has a splitting. -/
def splitting_of_is_iso_zero {X Y Z : 𝒜} (f : X ⟶ Y) [is_iso f] (hZ : is_zero Z) :
  splitting f (0 : Y ⟶ Z) :=
⟨(as_iso f).symm ≪≫ iso_biprod_zero hZ, by simp [hZ.eq_of_tgt _ 0], by simp⟩

include h

protected lemma mono : mono f :=
begin
  apply mono_of_mono _ h.retraction,
  rw h.ι_retraction,
  apply_instance
end

protected lemma epi : epi g :=
begin
  apply_with (epi_of_epi h.section) { instances := ff },
  rw h.section_π,
  apply_instance
end

instance : mono h.section :=
by { delta splitting.section, apply_instance }

instance : epi h.retraction :=
by { delta retraction, apply epi_comp }

end has_zero_morphisms

section preadditive
variables [preadditive 𝒜] [has_binary_biproducts 𝒜]
variables (h : splitting f g)

@[reassoc]
lemma retraction_ι_eq_id_sub :
  h.retraction ≫ f = 𝟙 _ - g ≫ h.section :=
eq_sub_iff_add_eq.mpr h.split_add

@[reassoc]
lemma π_section_eq_id_sub :
  g ≫ h.section = 𝟙 _ - h.retraction ≫ f :=
eq_sub_iff_add_eq.mpr ((add_comm _ _).trans h.split_add)

lemma splittings_comm (h h' : splitting f g) :
  h'.section ≫ h.retraction = - h.section ≫ h'.retraction :=
begin
  haveI := h.mono,
  rw ← cancel_mono f,
  simp [retraction_ι_eq_id_sub],
end

include h

lemma split : split f g :=
begin
  let φ := h.iso.hom ≫ biprod.fst,
  let χ := biprod.inr ≫ h.iso.inv,
  refine ⟨⟨h.retraction, h.section, h.ι_retraction, h.section_π, _,
    h.section_retraction, h.split_add⟩⟩,
  rw [← h.inl_comp_iso_eq, category.assoc, h.iso_comp_eq_snd, biprod.inl_snd],
end

@[reassoc] lemma comp_eq_zero : f ≫ g = 0 :=
h.split.1.some_spec.some_spec.2.2.1

variables [has_kernels 𝒜] [has_images 𝒜] [has_zero_object 𝒜] [has_cokernels 𝒜]

protected lemma exact : exact f g :=
begin
  rw exact_iff_exact_of_iso f g (biprod.inl : A ⟶ A ⊞ C) (biprod.snd : A ⊞ C ⟶ C) _ _ _,
  { exact exact_inl_snd _ _ },
  { refine arrow.iso_mk (iso.refl _) h.iso _,
    simp only [iso.refl_hom, arrow.mk_hom, category.id_comp, comp_iso_eq_inl], },
  { refine arrow.iso_mk h.iso (iso.refl _) _,
    dsimp, simp, },
  { refl }
end

protected
lemma short_exact : short_exact f g :=
{ mono := h.mono, epi := h.epi, exact := h.exact }

end preadditive

end splitting

end category_theory


import local.ample_relation
import global.relation

set_option trace.filter_inst_type true

/-! # Link with the local story

This file bridges the gap between Chapter 2 and Chapter 3. It builds on the
`smooth_embbeding` file but goes all the way to vector spaces (the previous file
is about embedding any manifold into another one).
-/

noncomputable theory

open set function filter (hiding map_smul) charted_space smooth_manifold_with_corners
open_locale topology manifold

section loc
/-! ## Localizing relations and 1-jet sections

Now we really bridge the gap all the way to vector spaces.
-/

variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
variables {E' : Type*} [normed_add_comm_group E'] [normed_space ℝ E']

/-- Convert a 1-jet section between vector spaces seen as manifold to a 1-jet section
between those vector spaces. -/
def one_jet_sec.loc (F : one_jet_sec 𝓘(ℝ, E) E 𝓘(ℝ, E') E') : jet_sec E E' :=
{ f := F.bs,
  f_diff := F.smooth_bs.cont_diff,
  φ := λ x, (F x).2,
  φ_diff := begin
    rw [cont_diff_iff_cont_diff_at],
    intro x₀,
    have : smooth_at _ _ _ _ := F.smooth x₀,
    simp_rw [smooth_at_one_jet_bundle, in_coordinates_core, in_coordinates_core',
      tangent_bundle_core_index_at, tangent_bundle.coord_change_at_self,
      continuous_linear_map.one_def, continuous_linear_map.comp_id, continuous_linear_map.id_comp]
      at this,
      exact this.2.2.cont_diff_at,
  end }

lemma one_jet_sec.loc_hol_at_iff (F : one_jet_sec 𝓘(ℝ, E) E 𝓘(ℝ, E') E') (x : E) :
F.loc.is_holonomic_at x ↔ F.is_holonomic_at x :=
begin
  dsimp only [one_jet_sec.is_holonomic_at],
  rw mfderiv_eq_fderiv,
  exact iff.rfl
end

/-- Turns a relation between `E` and `E'` seen as manifolds into a relation between them
seen as vector spaces. One annoying bit is `equiv.prod_assoc E E' $ E →L[ℝ] E'` that is needed
to reassociate a product of types. -/
def rel_mfld.rel_loc (R : rel_mfld 𝓘(ℝ, E) E 𝓘(ℝ, E') E') : rel_loc E E' :=
(homeomorph.prod_assoc _ _ _).symm ⁻¹'
  ((one_jet_bundle_model_space_homeomorph 𝓘(ℝ, E) 𝓘(ℝ, E')).symm ⁻¹' R)

lemma ample_of_ample (R : rel_mfld 𝓘(ℝ, E) E 𝓘(ℝ, E') E') (hR : R.ample) :
  R.rel_loc.is_ample :=
by { rintro p ⟨x, y, ϕ⟩, exact @hR ⟨(x, y), ϕ⟩ p }

lemma is_open_of_is_open (R : rel_mfld 𝓘(ℝ, E) E 𝓘(ℝ, E') E') (hR : is_open R) :
  is_open R.rel_loc :=
(homeomorph.is_open_preimage _).mpr $ (homeomorph.is_open_preimage _).mpr hR

end loc

section unloc
/-! ## Unlocalizing relations and 1-jet sections

-/

variables {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
variables {E' : Type*} [normed_add_comm_group E'] [normed_space ℝ E']

/-- Convert a 1-jet section between vector spaces to a 1-jet section
between those vector spaces seen as manifolds. -/
def jet_sec.unloc (𝓕 : jet_sec E E') : one_jet_sec 𝓘(ℝ, E) E 𝓘(ℝ, E') E' :=
{ bs := 𝓕.f,
  ϕ := λ x, (𝓕 x).2,
  smooth' := begin
    intros a,
    refine smooth_at_one_jet_bundle.mpr _,
    refine ⟨smooth_at_id, 𝓕.f_diff.cont_mdiff a, _⟩,
    simp_rw [in_coordinates_core_model_space],
    exact 𝓕.φ_diff.cont_mdiff a
  end }

lemma jet_sec.unloc_hol_at_iff (𝓕 : jet_sec E E') (x : E) :
𝓕.unloc.is_holonomic_at x ↔ 𝓕.is_holonomic_at x :=
begin
  dsimp only [one_jet_sec.is_holonomic_at],
  rw mfderiv_eq_fderiv,
  exact iff.rfl
end

def htpy_jet_sec.unloc (𝓕 : htpy_jet_sec E E') : htpy_one_jet_sec 𝓘(ℝ, E) E 𝓘(ℝ, E') E' :=
{ bs := λ t, (𝓕 t).f,
  ϕ := λ t x, (𝓕 t x).2,
  smooth' := begin
    intros a,
    refine smooth_at_one_jet_bundle.mpr _,
    refine ⟨smooth_at_snd,
      (𝓕.f_diff.cont_mdiff (a.fst, a.snd)).comp a (smooth_at_fst.prod_mk_space smooth_at_snd), _⟩,
    dsimp [in_coordinates_core, in_coordinates_core', chart_at],
    simp only [range_id, fderiv_within_univ, fderiv_id, continuous_linear_map.id_comp,
      continuous_linear_map.comp_id],
    exact (𝓕.φ_diff.cont_mdiff (a.fst, a.snd)).comp a (smooth_at_fst.prod_mk_space smooth_at_snd),
  end }

end unloc

variables
  {E : Type*} [normed_add_comm_group E] [normed_space ℝ E]
  {H : Type*} [topological_space H]
  (I : model_with_corners ℝ E H)
  (M : Type*) [topological_space M] [charted_space H M] [smooth_manifold_with_corners I M]
  {E' : Type*} [normed_add_comm_group E'] [normed_space ℝ E']
  {H' : Type*} [topological_space H']
  (I' : model_with_corners ℝ E' H')
  (M' : Type*) [metric_space M'] [charted_space H' M'] [smooth_manifold_with_corners I' M']

variables {R : rel_mfld I M I' M'}

/-- A pair of charts together with a compact subset of the first vector space. -/
structure chart_pair :=
(φ : open_smooth_embedding 𝓘(ℝ, E) E I M)
(ψ : open_smooth_embedding 𝓘(ℝ, E') E' I' M')
(K₁ : set E)
(hK₁ : is_compact K₁)

variables  (p : chart_pair I M I' M') {I M I' M'}

variable (p)

def formal_sol.localize (F : formal_sol R) (hF : range (F.bs ∘ p.φ) ⊆ range p.ψ) :
  (R.localize p.φ p.ψ).rel_loc.formal_sol :=
{ is_sol := λ x, (F.localize_mem_iff p.φ p.ψ hF).mpr (F.is_sol _),
  ..(F.localize p.φ p.ψ hF).loc }

lemma formal_sol.is_holonomic_localize (F : formal_sol R) (hF : range (F.bs ∘ p.φ) ⊆ range p.ψ)
  (x) (hx : F.is_holonomic_at (p.φ x)) : (F.localize p hF).is_holonomic_at x :=
(one_jet_sec.loc_hol_at_iff _ _).mpr $
  (is_holonomic_at_localize_iff F.to_one_jet_sec p.φ p.ψ hF x).mpr hx

variables (F : htpy_formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol)

structure chart_pair.compat' (F : formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol) : Prop :=
(hF : range (F.bs ∘ p.φ) ⊆ range p.ψ)
(hFF : ∀ x ∉ p.K₁, ∀ t, 𝓕 t x = F.localize p hF x)

def rel_loc.htpy_formal_sol.unloc : htpy_formal_sol (rel_mfld.localize p.φ p.ψ R) :=
{ is_sol' := 𝓕.is_sol,
  ..𝓕.to_htpy_jet_sec.unloc}

lemma rel_loc.htpy_formal_sol.unloc_congr {𝓕 𝓕' : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol}
  {t t' x} (h : 𝓕 t x = 𝓕' t' x) : 𝓕.unloc p t x = 𝓕'.unloc p t' x :=
begin
  ext1,
  refl,
  change (𝓕 t x).1 = (𝓕' t' x).1,
  rw h,
  change (𝓕 t x).2 = (𝓕' t' x).2,
  rw h
end

lemma rel_loc.htpy_formal_sol.unloc_congr_const {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol}
  {𝓕' : (R.localize p.φ p.ψ).rel_loc.formal_sol}
  {t x} (h : 𝓕 t x = 𝓕' x) : 𝓕.unloc p t x = 𝓕'.unloc x :=
begin
  ext1,
  refl,
  change (𝓕 t x).1 = (𝓕' x).1,
  rw h,
  change (𝓕 t x).2 = (𝓕' x).2,
  rw h
end

lemma rel_loc.htpy_formal_sol.unloc_congr' {𝓕 𝓕' : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol}
  {t t'} (h : 𝓕 t = 𝓕' t') : 𝓕.unloc p t = 𝓕'.unloc p t' :=
begin
  apply formal_sol.coe_inj,
  intro x,
  apply rel_loc.htpy_formal_sol.unloc_congr,
  rw h,
end

@[simp]
lemma formal_sol.transfer_unloc_localize (F : formal_sol R)
  (hF : range (F.bs ∘ p.φ) ⊆ range p.ψ) (x : E) :
  p.φ.transfer p.ψ ((F.localize p hF).unloc x) = F (p.φ x) :=
transfer_localize F.to_one_jet_sec p.φ p.ψ hF x

open_locale classical
variables [t2_space M]

def chart_pair.mk_htpy (F : formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol)
   : htpy_formal_sol R :=
if h : p.compat' F 𝓕 then p.φ.update_formal_sol p.ψ F (𝓕.unloc p) p.hK₁
  (λ t x (hx : x ∉ p.K₁), begin
  rw [← F.transfer_unloc_localize p h.1, rel_loc.htpy_formal_sol.unloc_congr_const p (h.hFF x hx t)],
  refl,
  end) else F.const_htpy

lemma chart_pair.mk_htpy_congr (F : formal_sol R)
  {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol} {t t' : ℝ} (h : 𝓕 t = 𝓕 t') :
  p.mk_htpy F 𝓕 t = p.mk_htpy F 𝓕 t' :=
begin
  unfold chart_pair.mk_htpy,
  by_cases hF : p.compat' F 𝓕,
  { simp only [dif_pos hF],
    apply formal_sol.coe_inj,
    intro x,
    rw [p.φ.update_formal_sol_apply, p.φ.update_formal_sol_apply,
        rel_loc.htpy_formal_sol.unloc_congr' p h] },
  { simp only [dif_neg hF], refl },
end

lemma chart_pair.mk_htpy_eq_self (F : formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol) {t m}
  (hm : ∀ hF : range (F.bs ∘ p.φ) ⊆ range p.ψ, ∀ x ∈ p.K₁, m = p.φ x → 𝓕 t x = F.localize p hF x) :
  p.mk_htpy F 𝓕 t m = F m :=
begin
  rw [chart_pair.mk_htpy],
  split_ifs,
  { refine (p.φ.Jupdate_apply _ _ _ _ _).trans _,
    rw [open_smooth_embedding.update],
    split_ifs with h',
    { obtain ⟨x, rfl⟩ := h',
      rw [one_jet_bundle.embedding_to_fun, p.φ.left_inv],
      have : (𝓕 t).unloc x = F.to_one_jet_sec.localize p.φ p.ψ h.hF x,
      { have : 𝓕 t x = F.localize p h.hF x,
        { by_cases h'' : x ∈ p.K₁,
          { exact hm h.hF x h'' rfl },
          { exact h.hFF x h'' t } },
        rw [prod.ext_iff] at this,
        ext1, refl, exact this.1, dsimp only, exact this.2 },
      change p.φ.transfer p.ψ ((𝓕 t).unloc x) = F (p.φ x),
      rw [this, transfer_localize],
      refl },
    refl },
  refl,
end

lemma chart_pair.mk_htpy_eq_of_not_mem (F : formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol) {t} {m} (hm : m ∉ p.φ '' p.K₁) :
  p.mk_htpy F 𝓕 t m = F m :=
chart_pair.mk_htpy_eq_self p F 𝓕 $
  by { rintro hF x hx rfl, exfalso, exact hm (mem_image_of_mem _ hx) }

lemma chart_pair.mk_htpy_eq_of_eq (F : formal_sol R)
  (𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol) (h𝓕 : p.compat' F 𝓕) {t x}
  (h : 𝓕 t x = F.localize p h𝓕.1 x) :
  p.mk_htpy F 𝓕 t (p.φ x) = F (p.φ x) :=
begin
  dsimp only [chart_pair.mk_htpy],
  split_ifs,
  simp only [open_smooth_embedding.update_formal_sol_apply_image],
  rw [rel_loc.htpy_formal_sol.unloc_congr_const p, formal_sol.transfer_unloc_localize p F h𝓕.1 x],
  exact h,
end

lemma chart_pair.mk_htpy_eq_of_forall {F : formal_sol R}
  {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol} (h𝓕 : p.compat' F 𝓕) {t}
  (h : 𝓕 t = F.localize p h𝓕.1) :
  p.mk_htpy F 𝓕 t = F :=
formal_sol.coe_inj $ λ m, chart_pair.mk_htpy_eq_self p F 𝓕 $
    by { rintro hF y hy rfl, by { rw h, refl } }

lemma chart_pair.mk_htpy_localize {F : formal_sol R}
  {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol} {t e}
  (h : p.compat' F 𝓕) (rg : range ((p.mk_htpy F 𝓕 t).bs ∘ p.φ) ⊆ range p.ψ) :
  (p.mk_htpy F 𝓕 t).to_one_jet_sec.localize p.φ p.ψ rg e = (𝓕 t).unloc e :=
begin
  simp_rw [chart_pair.mk_htpy, dif_pos h] at rg ⊢,
  exact p.φ.Jupdate_localize p.ψ _ _ t rg e
end

lemma chart_pair.mk_htpy_is_holonomic_at_iff {F : formal_sol R}
  {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol} (h : p.compat' F 𝓕) {t e} :
  (p.mk_htpy F 𝓕 t).is_holonomic_at (p.φ e) ↔ (𝓕 t).is_holonomic_at e :=
begin
  have rg : range ((p.mk_htpy F 𝓕 t).bs ∘ p.φ) ⊆ range p.ψ,
  { rintros - ⟨e, rfl⟩,
    dsimp only [chart_pair.mk_htpy],
    simp only [dif_pos h],
    rw p.φ.update_formal_sol_bs p.ψ p.hK₁,
    simp only [comp_app, open_smooth_embedding.update_apply_embedding, mem_range_self] },
  rw [← is_holonomic_at_localize_iff _ p.φ p.ψ rg e,
      ← jet_sec.unloc_hol_at_iff],
  exact one_jet_sec.is_holonomic_at_congr (eventually_of_forall $ λ e, p.mk_htpy_localize h rg)
end

lemma chart_pair.dist_update' [finite_dimensional ℝ E'] {δ : M → ℝ} (hδ_pos : ∀ x, 0 < δ x)
  (hδ_cont : continuous δ) {F : formal_sol R} (hF : range (F.bs ∘ p.φ) ⊆ range p.ψ) :
  ∃ η > (0 : ℝ),
    ∀ {𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol}, ∀ hF𝓕 : p.compat' F 𝓕,
    ∀ (e ∈ p.K₁) (t ∈ (Icc 0 1 : set ℝ)), ‖(𝓕 t).f e - (F.localize p hF).f e‖ < η →
    dist (((p.mk_htpy F 𝓕) t).bs $ p.φ e) (F.bs $ p.φ e) < δ (p.φ e) :=
begin
  let bsF := (λ m, F.bs m),
  have : ∀ 𝓕 : (R.localize p.φ p.ψ).rel_loc.htpy_formal_sol, p.compat' F 𝓕 → ∀ t e,
    (p.mk_htpy F 𝓕 t).bs (p.φ e) = p.φ.update p.ψ bsF (λ e, (𝓕.unloc p t).bs e) (p.φ e),
  { -- TODO: this proof needs more lemmas
    intros 𝓕 h𝓕 t e,
    change (p.mk_htpy F 𝓕 t (p.φ e)).1.2 = p.φ.update p.ψ bsF (λ e, (𝓕.unloc p t).bs e) (p.φ e),
    simp only [open_smooth_embedding.update_apply_embedding],
    dsimp only [chart_pair.mk_htpy],
    rw [dif_pos h𝓕, open_smooth_embedding.update_formal_sol_apply],
    dsimp only,
    simp_rw [open_smooth_embedding.update_apply_embedding, one_jet_bundle.embedding_to_fun,
      open_smooth_embedding.transfer_fst_snd],
    refl },
  rcases p.φ.dist_update p.ψ p.hK₁ (is_compact_Icc : is_compact (Icc 0 1 : set ℝ)) (λ t m, F.bs m)
    (F.smooth_bs.continuous.comp continuous_snd) (λ t, (range_comp bsF p.φ) ▸ hF) hδ_pos hδ_cont
    with ⟨η, η_pos, hη⟩,
  refine ⟨η, η_pos, _⟩,
  intros 𝓕 H e he t ht het,
  simp only [this 𝓕 H], clear this,
  rw ← dist_eq_norm at het,
  exact hη (λ t e, (𝓕.unloc p t).bs e) 1 ⟨zero_le_one, le_rfl⟩ t ht e he het
end


set_option trace.Meta.sizeOf true in
mutual
  inductive AList (α β : Type u)
    | nil
    | cons (a : α) (t : BList α β)

  inductive BList (α β : Type u)
    | cons (b : β) (t : AList α β)
end

#print AList.nil.sizeOf_spec
#print AList.cons.sizeOf_spec
#print BList.cons.sizeOf_spec

mutual
  inductive Foo (α : Type u)
    | mk (cs : AList (Foo α) (Boo α))

  inductive Boo (α : Type u)
    | mk (a : α) (cs : BList (Foo α) (Boo α))
end

namespace Foo

theorem aux_1 [SizeOf α] (a : AList (Foo α) (Boo α)) : Foo._sizeOf_3 a = sizeOf a :=
  @AList.rec (Foo α) (Boo α) (fun a => Foo._sizeOf_3 a = sizeOf a) (fun b => Foo._sizeOf_4 b = sizeOf b)
    rfl
    (fun a t ih => by
      show 1 + sizeOf a + Foo._sizeOf_4 t = sizeOf (AList.cons a t)
      rw ih
      rfl)
    (fun b t ih => by
      show 1 + sizeOf b + Foo._sizeOf_3 t = sizeOf (BList.cons b t)
      rw ih
      rfl)
    a

theorem aux_2 [SizeOf α] (a : BList (Foo α) (Boo α)) : Foo._sizeOf_4 a = sizeOf a :=
  @BList.rec (Foo α) (Boo α) (fun a => Foo._sizeOf_3 a = sizeOf a) (fun b => Foo._sizeOf_4 b = sizeOf b)
    rfl
    (fun a t ih => by
      show 1 + sizeOf a + Foo._sizeOf_4 t = sizeOf (AList.cons a t)
      rw ih
      rfl)
    (fun b t ih => by
      show 1 + sizeOf b + Foo._sizeOf_3 t = sizeOf (BList.cons b t)
      rw ih
      rfl)
    a


/-
Copyright 2020 Google LLC

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
 -/
import data.real.ennreal
import formal_ml.nat
import formal_ml.nnreal
import formal_ml.with_top
import formal_ml.lattice

-- ennreal is a canonically_ordered_add_monoid
-- ennreal is not a decidable_linear_ordered_semiring
-- Otherwise (0 < c) → (c * a) ≤ (c * b) → (a ≤ b),
-- but this does not hold for c =⊤, a = 1, b = 0.
-- This is because ennreal is not an ordered_cancel_add_comm_monoid.
-- Nor is it an ordered_cancel_comm_monoid
-- This implies it is also not an ordered_semiring

lemma ennreal_coe_eq_lift {a:ennreal} {b:nnreal}:a = b → (a.to_nnreal = b) :=
begin
  intro A1,
  have A2:(a.to_nnreal)=(b:ennreal).to_nnreal,
  {
    rw A1,
  },
  rw ennreal.to_nnreal_coe at A2,
  exact A2,
end

/-
  This is one of those complicated inequalities that is probably too rare to justify a
  lemma. However, since it shows up, we give it the canonical name and move on.
-/
lemma ennreal_le_to_nnreal_of_ennreal_le_of_ne_top {a:nnreal} {b:ennreal}:
    b≠ ⊤ → (a:ennreal) ≤ b → (a ≤ b.to_nnreal) :=
begin
  intros A1 A2,
  cases b,
  {
    simp at A1,
    exfalso,
    apply A1,
  },
  {
    have A3:(b:ennreal) = (some b) := rfl,
    rw ← A3,
    rw (@ennreal.to_nnreal_coe b),
    rw ← ennreal.coe_le_coe,
    rw A3,
    apply A2,
  }
end

lemma ennreal_add_monoid_smul_def{n:ℕ} {c:ennreal}: n •ℕ c = ↑(n) * c :=
begin
  induction n,
  {
    simp,
  },
  {
    simp,
  }
end

lemma ennreal_lt_add_ennreal_one (x:nnreal):(x:ennreal) < (1:ennreal) + (x:ennreal) :=
begin
  apply ennreal.coe_lt_coe.mpr,
  simp,
  apply canonically_ordered_semiring.zero_lt_one,
end

lemma ennreal.infi_le {α:Sort*} {f:α → ennreal} {b : ennreal}:
   (∀ (ε : nnreal), 0 < ε → b < ⊤ → (∃a, f a  ≤ b + ↑ε)) → infi f ≤ b :=
begin
  intro A1,
  apply @ennreal.le_of_forall_pos_le_add,
  intros ε A2 A3,
  have A4 := A1 ε A2 A3,
  cases A4 with a A4,
  apply le_trans _ A4,
  apply @infi_le ennreal _ _,
end

lemma ennreal.forall_epsilon_le_iff_le : ∀{a b : ennreal}, (∀ε:nnreal, 0 < ε → b < ⊤ → a ≤ b + ε) ↔ a ≤ b :=
begin
  intros a b,
  split,
  apply ennreal.le_of_forall_pos_le_add,
  intros A1 ε B1 B2,
  apply le_add_right A1,
end

lemma ennreal.lt_of_add_le_of_pos {x y z:ennreal}:x + y ≤ z → 0 < y → x < ⊤ → x < z :=
begin
  cases x;cases y;cases z;try {simp},
  {repeat {rw ← ennreal.coe_add},rw ennreal.coe_le_coe,apply nnreal.lt_of_add_le_of_pos},
end

lemma ennreal.iff_infi_le {α:Sort*} {f:α → ennreal} {b : ennreal}:
   (∀ (ε : nnreal), 0 < ε → b < ⊤ → (∃a, f a  ≤ b + ↑ε)) ↔ infi f ≤ b :=
begin
  --intro A1,
  --rw ← @ennreal.forall_epsilon_le_iff_le (infi f) b,
  split,
  apply ennreal.infi_le,
  intro A1,
  intros ε A2 A3,
  apply classical.by_contradiction,
  intro A4,
  apply not_lt_of_ge A1,
  have A5:b + ↑ε ≤ infi f,
  { apply @le_infi ennreal _ _, intro a,
    have A5:=(forall_not_of_not_exists A4) a,
    simp at A5,
    apply le_of_lt A5,
  },
  apply ennreal.lt_of_add_le_of_pos A5,
  simp,apply A2,
  apply A3,
end

lemma ennreal.exists_le_infi_add {α:Type*} (f:α → ennreal) [N:nonempty α] {ε:nnreal}:0 < ε → (∃ a, f a ≤ infi f + ε) :=
begin
  intros A1,
  have A2:infi f ≤ infi f,
  {apply le_refl _},
  rw ← ennreal.iff_infi_le at A2,
  cases (decidable.em (infi f < ⊤)) with A3 A3,
  apply A2 ε  A1 A3,
  simp only [not_lt, top_le_iff] at A3,
  --cases N,
  have a := classical.choice N,
  apply exists.intro a,
  rw A3,
  simp,
end

lemma ennreal.le_supr {α:Type*} {f:α → ennreal} {b : ennreal}:(∀ (ε : nnreal), 0 < ε → (supr f < ⊤) → (∃a,  b ≤ f a + ε)) → b ≤ supr f :=
begin
  intro A1,
  apply @ennreal.le_of_forall_pos_le_add,
  intros ε A2 A3,
  have A4 := A1 ε A2 A3,
  cases A4 with a A4,
  apply le_trans A4,
  have A5:=@le_supr ennreal _ _ f a,
  apply add_le_add A5,
  apply le_refl _,
end

/-This isn't true. Specifically, for any non-finite sets, one can construct a counterexample.
  Using ℕ as an example, f:ℕ → ℕ → ennreal := λ a b, if (a < b) then 1 else 0.
lemma ennreal.supr_infi_eq_infi_supr {α β:Type*} [nonempty α] [nonempty β] [partial_order β] {f:α → β → ennreal}:(∀ a:α, monotone (f a)) →
  (⨅ (a:α), ⨆ (b:β), f a b )= ( ⨆ (b:β), ⨅ (a:α), f a b) :=
begin

 -/

lemma ennreal.not_add_le_of_lt_of_lt_top {a b:ennreal}:
   (0 < b) → (a < ⊤) → ¬(a + b) ≤ a :=
begin
  intros A1 A2 A3,
  have A4:(⊤:ennreal) = none := rfl,
  cases a,
  {
    simp at A2,
    apply A2,
  },
  cases b,
  {
    rw ←A4 at A3,
    rw with_top.add_top at A3,
    rw top_le_iff at A3,
    simp at A3,
    apply A3,
  },
  simp at A3,
  rw ← ennreal.coe_add at A3,
  rw ennreal.coe_le_coe at A3,
  simp at A1,
  apply nnreal.not_add_le_of_lt A1,
  apply A3,
end

lemma ennreal.lt_add_of_pos_of_lt_top {a b:ennreal}:
   (0 < b) → (a < ⊤) → a < a + b :=
begin
  intros A1 A2,
  apply lt_of_not_ge,
  apply ennreal.not_add_le_of_lt_of_lt_top A1 A2,
end

lemma ennreal.infi_elim {α:Sort*} {f:α → ennreal} {ε:nnreal}:
   (0 < ε) → (infi f < ⊤) → (∃a, f a  ≤ infi f + ↑ε) :=
begin
  intros A1 A2,
  have A3:¬(infi f+(ε:ennreal)≤ infi f),
  {
    apply ennreal.not_add_le_of_lt_of_lt_top _ A2,
    simp,
    apply A1,
  },
  apply (@classical.exists_of_not_forall_not α (λ (a  : α), f a ≤ infi f + ↑ε)),
  intro A4,
  apply A3,
  apply @le_infi ennreal α _,
  intro a,
  cases  (le_total (infi f + ↑ε) (f a)) with A5 A5,
  apply A5,
  have A6 := A4 a,
  exfalso,
  apply A6,
  apply A5,
end

lemma ennreal.zero_le {a:ennreal}:0 ≤ a :=
begin
  simp,
end

lemma ennreal.sub_top {a:ennreal}:a - ⊤ = 0 :=
begin
  simp,
end

lemma ennreal.sub_lt_of_pos_of_pos {a b:ennreal}:(0 < a) →
    (0 < b) → (a ≠ ⊤) → (a - b) < a :=
begin
  intros A1 A2 A3,
  cases a,
  {
    exfalso,
    simp at A3,
    apply A3,
  },
  cases b,
  {
    rw ennreal.none_eq_top,
    rw ennreal.sub_top,
    apply A1,
  },
  simp,
  rw ← ennreal.coe_sub,
  rw ennreal.coe_lt_coe,
  apply nnreal.sub_lt_of_pos_of_pos,
  {
    simp at A1,
    apply A1,
  },
  {
    simp at A2,
    apply A2,
  },
end

lemma ennreal.Sup_elim {S:set ennreal} {ε:nnreal}:
   (0 < ε) → (S.nonempty)  → (Sup S ≠ ⊤) → (∃s∈S, (Sup S) - ε ≤ s) :=
begin
  intros A1 A2 A3,
  cases classical.em (Sup S = 0) with A4 A4,
  {
    rw A4,
    have A5:= set.nonempty_def.mp A2,
    cases A5 with s A5,
    apply exists.intro s,
    apply exists.intro A5,
    simp,
  },
  have A5:(0:ennreal) = ⊥ := rfl,
  have B1:(Sup S) - ε < (Sup S),
  {
    apply ennreal.sub_lt_of_pos_of_pos,
    rw A5,
    rw bot_lt_iff_ne_bot,
    rw ← A5,
    apply A4,
    simp,
    apply A1,
    apply A3,
  },
  rw lt_Sup_iff at B1,
  cases B1 with a B1,
  cases B1 with B2 B3,
  apply exists.intro a,
  apply exists.intro B2,
  apply le_of_lt B3,
end

lemma ennreal.top_of_infi_top {α:Type*} {g:α → ennreal} {a:α}:((⨅ a', g a') = ⊤) →
  (g a = ⊤) :=
begin
  intro A1,
  rw ← top_le_iff,
  rw ← A1,
  apply @infi_le ennreal α _,
end

lemma of_infi_lt_top {P:Prop} {H:P→ ennreal}:infi H < ⊤ → P :=
begin
  intro A1,
  cases (classical.em P) with A2 A2,
  {
    apply A2,
  },
  {
    exfalso,
    unfold infi at A1,
    unfold set.range at A1,
    have A2:{x : ennreal | ∃ (y : P), H y = x}=∅,
    {
      ext;split;intro A2A,
      simp at A2A,
      exfalso,
      cases A2A with y A2A,
      apply A2,
      apply y,
      exfalso,
      apply A2A,
    },
    rw A2 at A1,
    simp at A1,
    apply A1,
  },
end

/-
lemma ennreal.add_le_add_left {a b c:ennreal}:
   b ≤ c → a + b ≤ a + c :=
begin
  intro A1,
  cases a,
  {
    simp,
  },
  cases b,
  {
    simp at A1,
    subst c,
    simp,
  },
  cases c,
  {
    simp,
  },
  simp,
  simp at A1,
  repeat {rw ← ennreal.coe_add},
  rw ennreal.coe_le_coe,
  apply @add_le_add_left nnreal _,
  apply A1,
end
-/

lemma ennreal.le_of_add_le_add_right
    {a b c:ennreal}:(c < ⊤)→
   (a + c ≤ b + c) → (a ≤ b) :=
begin
  rw add_comm a c,
  rw add_comm b c,
  apply ennreal.le_of_add_le_add_left
end

lemma ennreal.le_add {a b c:ennreal}:a ≤ b → a ≤ b + c :=
begin
  intro A1,
  apply @le_add_of_le_of_nonneg ennreal _,
  apply A1,
  simp,
end

lemma ennreal.add_lt_add_of_lt_of_le_of_lt_top {a b c d:ennreal}:d < ⊤ → c ≤ d → a < b → a + c < b + d :=
begin
  intros A1 A2 A3,
  rw le_iff_lt_or_eq at A2,
  cases A2 with A2 A2,
  {
    apply ennreal.add_lt_add A3 A2,
  },
  subst d,
  rw with_top.add_lt_add_iff_right,
  apply A3,
  apply A1,
end

lemma ennreal.le_of_sub_eq_zero {a b:ennreal}:
    a - b = 0 → a ≤ b :=
begin
  intros A1,
  simp at A1,
  apply A1,
end

--Used once in hahn.lean.
lemma ennreal.sub_add_sub {a b c:ennreal}:c ≤ b → b ≤ a → (a - b) + (b - c) = a - c :=
begin
  cases c;cases b;cases a;try {simp},
  repeat {rw ← ennreal.coe_sub <|> rw ← ennreal.coe_add <|> rw ennreal.coe_eq_coe},
  apply nnreal.sub_add_sub,
end

-- TODO: everything used below here.
lemma ennreal.inv_as_fraction {c:ennreal}:(1)/(c) = (c)⁻¹ :=
begin
  rw div_eq_mul_inv,
  rw one_mul,
end

lemma ennreal.add_lt_of_lt_sub {a b c:ennreal}:a < b - c → a + c < b :=
begin
  cases a;cases b;cases c;try {simp},
  {
    repeat {rw ← ennreal.coe_sub
            <|> rw ennreal.coe_lt_coe
            <|> rw ← ennreal.coe_add},
    apply nnreal.add_lt_of_lt_sub,
  },
end

lemma ennreal.lt_sub_of_add_lt {a b c:ennreal}: a + c < b → a < b - c :=
begin
  --intros AX A1,
  cases a;cases b;cases c;try {simp},
  {
    repeat {rw ← ennreal.coe_sub
            <|> rw ennreal.coe_lt_coe
            <|> rw ← ennreal.coe_add},
    apply nnreal.lt_sub_of_add_lt,
  },
end

lemma ennreal.eq_zero_or_zero_lt {x:ennreal}:¬(x=0) → (0 < x) :=
begin
  intro A1,
  have A2:= @lt_trichotomy ennreal _ x 0,
  cases A2,
  {
    exfalso,
    apply @ennreal.not_lt_zero x,
    apply A2,
  },
  cases A2,
  {
    exfalso,
    apply A1,
    apply A2,
  },
  {
    apply A2,
  },
end

--TODO: everything used below here.

lemma ennreal.sub_eq_of_add_of_not_top_of_le {a b c:ennreal}:a = b + c →
  c ≠ ⊤ →
  c ≤ a → a - c = b :=
begin
  intros A1 A4 A2,
  cases c,
  {
    exfalso,
    simp at A4,
    apply A4,
  },
  cases a,
  {
    simp,
    cases b,
    {
      refl,
    },
    exfalso,
    simp at A1,
    rw ← ennreal.coe_add at A1,
    apply ennreal.top_ne_coe A1,
  },
  cases b,
  {
    simp at A1,
    exfalso,
    apply A1,
  },
  {
    repeat {rw ennreal.some_eq_coe},
    rw ← ennreal.coe_sub,
    rw ennreal.coe_eq_coe,
    repeat {rw ennreal.some_eq_coe at A1},
    rw ← ennreal.coe_add at A1,
    rw ennreal.coe_eq_coe at A1,
    repeat {rw ennreal.some_eq_coe at A2},
    rw ennreal.coe_le_coe at A2,
    apply nnreal.sub_eq_of_add_of_le A1 A2,
  },
end

lemma ennreal.eq_add_of_sub_eq {a b c:ennreal}:b ≤ a →
  a - b = c → a = b + c :=
begin
  intros A1 A2,
  cases a;cases b,
  {
    simp,
  },
  {
    cases c,
    {
      simp,
    },
    exfalso,
    simp at A2,
    apply A2,
  },
  {
    exfalso,
    apply with_top.not_none_le_some _ A1,
  },
  simp at A2,
  rw ← ennreal.coe_sub at A2,
  cases c,
  {
    exfalso,
    simp at A2,
    apply A2,
  },
  {
    simp,
    rw ← ennreal.coe_add,
    rw ennreal.coe_eq_coe,
    simp at A2,
    simp at A1,
    apply nnreal.eq_add_of_sub_eq A1 A2,
  },
end

lemma ennreal.sub_lt_sub_of_lt_of_le {a b c d:ennreal}:a < b →
  c ≤ d →
  d ≤ a →
  a - d < b - c :=
begin
  intros A1 A2 A3,
  have B1:(⊤:ennreal) = none := rfl,
  have B2:∀ n:nnreal,  (some n) = n,
  {
    intro n,
    refl,
  },
  cases a,
  {
    exfalso,
    apply @with_top.not_none_lt nnreal _ b A1,
  },
  cases d,
  {
    exfalso,
    apply @with_top.not_none_le_some nnreal _ a A3,
  },
  cases c,
  {
    exfalso,
    apply @with_top.not_none_le_some nnreal _ d A2,
  },
  cases b,
  {
    simp,
    rw ← ennreal.coe_sub,
    rw B1,
    rw ← B2,
    apply with_top.some_lt_none,
  },
  repeat {rw B2},
  repeat {rw ← ennreal.coe_sub},
  rw ennreal.coe_lt_coe,
  apply nnreal.sub_lt_sub_of_lt_of_le,
  repeat {rw B2 at A1},
  rw ennreal.coe_lt_coe at A1,
  apply A1,

  repeat {rw B2 at A2},
  rw ennreal.coe_le_coe at A2,
  apply A2,

  repeat {rw B2 at A3},
  rw ennreal.coe_le_coe at A3,
  apply A3,
end

lemma ennreal.le_sub_add {a b c:ennreal}:b ≤ c → c ≤ a →
a ≤ a - b + c :=
begin
  cases a;cases b;cases c;try {simp},
  rw ← ennreal.coe_sub,
  rw ← ennreal.coe_add,
  rw ennreal.coe_le_coe,
  apply nnreal.le_sub_add,
end

lemma ennreal.le_sub_add' {a b:ennreal}:a ≤ a - b + b :=
begin
  cases a; cases b; simp,
  rw ← ennreal.coe_sub,
  rw ← ennreal.coe_add,
  rw ennreal.coe_le_coe,
  apply nnreal.le_sub_add',
end

lemma ennreal.add_sub_cancel {a b:ennreal}:b < ⊤ → a + b - b = a :=
begin
  cases a;cases b;try {simp},
end

lemma ennreal.exists_coe {x:ennreal}:x < ⊤ → ∃ v:nnreal, x = v :=
begin
  cases x;try {simp},
end

lemma ennreal.lt_of_add_le_of_le_of_sub_lt {a b c d e:ennreal}:c < ⊤ →
    a + b ≤ c → d ≤ b → c - e < a → d < e :=
begin
  cases c,simp,
  cases a;cases b;cases d;cases e;try {simp},
  rw ← ennreal.coe_add,
  rw ← ennreal.coe_sub,
  rw ennreal.coe_le_coe,
  rw ennreal.coe_lt_coe,
  apply nnreal.lt_of_add_le_of_le_of_sub_lt,
end

lemma ennreal.coe_sub_lt_self {a:nnreal} {b:ennreal}:
     0 < a  → 0 < b →
     (a:ennreal) - b < (a:ennreal) :=
begin
  cases b;simp,
  intros A1 A2,
  rw ← ennreal.coe_sub,
  rw ennreal.coe_lt_coe,
  apply nnreal.sub_lt_self A1 A2,
end

lemma ennreal.lt_of_lt_top_of_add_lt_of_pos {a b c:ennreal}:a < ⊤ →
      b + c ≤ a →
      0 < b →
      c < a :=
begin
  cases a;simp;
  cases b;cases c;simp,
  rw ← ennreal.coe_add,
  rw ennreal.coe_le_coe,
  apply nnreal.lt_of_add_lt_of_pos,
end

/-
  ennreal could be a linear_ordered_comm_group_with_zero,
  and therefore a ordered_comm_monoid.
  HOWEVER, I am not sure how to integrate this.
  I am going to just prove the basic results from the class.
  NOTE that this is strictly more general than
  ennreal.mul_le_mul_left.
-/
lemma ennreal.mul_le_mul_of_le_left {a b c:ennreal}:
  a ≤ b → c * a ≤ c * b :=
begin
  cases a;cases b;cases c;simp;
  try {
    cases (classical.em (c=0)) with B1 B1,
    {
      subst c,
      simp,
    },
    {
      have B2:(c:ennreal) * ⊤ = ⊤,
      {
        rw ennreal.mul_top,
        rw if_neg,
        intro B2A,
        apply B1,
        simp at B2A,
        apply B2A,
      },
      rw B2,
      {apply le_refl _ <|> simp},
    },
  },
  {
    cases (classical.em (b=0)) with B1 B1,
    {
      subst b,
      simp,
    },
    {
      have B2:⊤ * (b:ennreal) = ⊤,
      {
        rw ennreal.top_mul,
        rw if_neg,
        intro B2A,
        apply B1,
        simp at B2A,
        apply B2A,
      },
      rw B2,
      simp,
    },
  },
  rw ← ennreal.coe_mul,
  rw ← ennreal.coe_mul,
  rw ennreal.coe_le_coe,
  apply nnreal.mul_le_mul_of_le_left,
end

lemma ennreal.inverse_le_of_le {a b:ennreal}:
  a ≤ b →
  b⁻¹ ≤ a⁻¹ :=
begin
  intros A2,
  cases (classical.em (a = 0)) with A1 A1,
  {
    subst a,
    simp,
  },

  cases b,
  {
    simp,
  },
  cases (classical.em (b = 0)) with C1 C1,
  {
    subst b,
    simp at A2,
    exfalso,
    apply A1,
    apply A2,
  },
  simp,
  simp at A2,
  have B1: (a⁻¹ * b⁻¹) * a ≤  (a⁻¹ * b⁻¹) * b,
  {
    apply ennreal.mul_le_mul_of_le_left A2,
  },
  rw mul_comm a⁻¹  b⁻¹ at B1,
  rw mul_assoc at B1,
  rw ennreal.inv_mul_cancel at B1,
  rw mul_comm (b:ennreal)⁻¹  a⁻¹ at B1,
  rw mul_assoc at B1,
  rw mul_one at B1,
  rw ennreal.inv_mul_cancel at B1,
  rw mul_one at B1,
  apply A2,
  {
    simp [C1],
  },
  {
    simp,
  },
  {
    apply A1,
  },
  {
    rw ← lt_top_iff_ne_top,
    apply lt_of_le_of_lt A2,
    simp,
  },
end

lemma ennreal.nat_coe_add {a b:ℕ}:(a:ennreal) + (b:ennreal) =
    ((@has_add.add nat _ a  b):ennreal) :=
begin
  simp,
end

lemma ennreal.nat_coe_le_coe {a b:ℕ}:(a:ennreal) ≤ (b:ennreal) ↔ (a ≤ b) :=
begin
  have B1:(a:ennreal) = ((a:nnreal):ennreal),
  {
    simp,
  },
  have B2:(b:ennreal) = ((b:nnreal):ennreal),
  {
    simp,
  },
  rw B1,
  rw B2,
  rw ennreal.coe_le_coe,
  split;intros A1,
  {
    simp at A1,
    apply A1,
  },
  {
    simp,
    apply A1,
  },
end

------------- from Radon-Nikodym --------

lemma ennreal.inv_mul_eq_inv_mul_inv {a b:ennreal}:(a≠ 0) → (b≠ 0) → (a * b)⁻¹=a⁻¹ * b⁻¹ :=
begin
  cases a;simp;cases b;simp,
  intros A1 A2,
  rw ← ennreal.coe_mul,
  repeat {rw ← ennreal.coe_inv},
  rw ← ennreal.coe_mul,
  rw ennreal.coe_eq_coe,
  apply @nnreal.inv_mul_eq_inv_mul_inv a b,
  apply A2,
  apply A1,
  rw ← @nnreal.pos_iff (a * b),
  rw nnreal.mul_pos_iff_pos_pos,
  repeat {rw canonically_ordered_add_monoid.zero_lt_iff_ne_zero},
  apply and.intro A1 A2,
end

lemma ennreal.div_dist {a b c:ennreal}:(b≠ 0) → (c≠ 0) → a/(b * c)=(a/b)/c :=
begin
  intros A1 A2,
  rw div_eq_mul_inv,
  rw ennreal.inv_mul_eq_inv_mul_inv,
  rw ← mul_assoc,
  repeat {rw div_eq_mul_inv},
  apply A1,
  apply A2,
end

lemma ennreal.div_eq_zero_iff {a b:ennreal}:a/b=0 ↔ (a = 0) ∨ (b = ⊤) :=
begin
  cases a;cases b;split;simp;intros A1;simp;simp at A1,
end

/-
  Helper function to lift nnreal.exists_unit_frac_lt_pos to ennreal.
 -/
lemma ennreal.exists_unit_frac_lt_pos' {ε:nnreal}:0 < ε → (∃ n:ℕ, (1/((n:ennreal) + 1)) < (ε:ennreal)) :=
begin
  intros A1,
--  simp at A1,
  have C1:= nnreal.exists_unit_frac_lt_pos A1,
  cases C1 with n A1,
  apply exists.intro n,
  have D1:((1:nnreal):ennreal) = 1 := rfl,
  rw ← D1,
  have D2:((n:nnreal):ennreal) = (n:ennreal),
  {
    simp,
  },
  rw ← D2,
  rw ← ennreal.coe_add,
  rw ← ennreal.coe_div,
  rw ennreal.coe_lt_coe,
  apply A1,
  simp,
end

lemma ennreal.exists_unit_frac_lt_pos {ε:ennreal}:0 < ε → (∃ n:ℕ, (1/((n:ennreal) + 1)) < ε) :=
begin
  cases ε,
  {
     intros A1,
     have B1:(0:nnreal) < (1:nnreal),
     {
       apply zero_lt_one,
     },
     have B1:=ennreal.exists_unit_frac_lt_pos' B1,
     cases B1 with n B1,
     apply exists.intro n,
     apply lt_of_lt_of_le B1,
     simp,
  },
  {
    intros A1,
    simp at A1,
    have C1:= ennreal.exists_unit_frac_lt_pos' A1,
    apply C1,
  },
end

lemma ennreal.zero_of_le_all_unit_frac {x:ennreal}:
    (∀ (n:ℕ), (x ≤ 1/((n:ennreal) + 1))) →  (x = 0) :=
begin
  intros A1,
  rw ← not_exists_not at A1,
  apply by_contradiction,
  intros B1,
  apply A1,
  have B2:0 < x,
  {
    rw canonically_ordered_add_monoid.zero_lt_iff_ne_zero,
    apply B1,
  },
  have B3:= ennreal.exists_unit_frac_lt_pos B2,
  cases B3 with n B3,
  apply exists.intro n,
  apply not_le_of_lt,
  apply B3,
end

lemma ennreal.unit_frac_pos {n:ℕ}:(1/((n:ennreal) + 1))>0 :=
begin
  simp,
end

lemma ennreal.div_eq_top_iff {a b:ennreal}:a/b=⊤ ↔
                             ((a = ⊤)∧(b≠ ⊤) )∨ ((a≠ 0)∧(b=0)):=
begin
  rw div_eq_mul_inv,
  cases a;cases b;simp,
end

lemma ennreal.unit_frac_ne_top {n:ℕ}:(1/((n:ennreal) + 1))≠ ⊤ :=
begin
  intro A1,
  rw ennreal.div_eq_top_iff at A1,
  simp at A1,
  apply A1,
end

lemma lt_eq_le_compl {δ α:Type*}
  [linear_order α] {f g : δ → α}:{a | f a < g a} ={a | g a ≤ f a}ᶜ :=
begin
    apply set.ext,
    intros ω;split;intros A3A;simp;simp at A3A;apply A3A,
end

lemma ennreal.lt_add_self {a b:ennreal}:a < ⊤ → 0 < b → a < a + b :=
begin
  cases a;cases b;simp,
  intros A1,
  rw ← ennreal.coe_add,
  rw ennreal.coe_lt_coe,
  simp,
  apply A1,
end

lemma ennreal.lt_add_pos {x ε:ennreal}: (x < ⊤) → (0 < ε) → (x < x + ε)  :=
begin
  cases ε; cases x; simp,
  rw ← ennreal.coe_add,
  rw ennreal.coe_lt_coe,
  apply nnreal.lt_add_pos,
end

lemma ennreal.add_pos_le_false {x ε:ennreal}: (x < ⊤) → (0 < ε) → (x + ε ≤ x) → false :=
begin
  cases ε; cases x; simp,
  rw ← ennreal.coe_add,
  rw ennreal.coe_le_coe,
  apply nnreal.add_pos_le_false,
end

lemma ennreal.le_of_infi {α:Sort*} {f:α → ennreal} {ε:nnreal}:
((⨅ (a:α), f a) < ⊤) → (0 < ε) → (∃ (a:α), f a ≤ ( (⨅ (a:α), f a) + ε)) :=
begin
  intros h1 h2,
  have h3:infi f ≤ (⨅ (a:α), f a),
  { apply le_refl _, },
  rw ← @ennreal.iff_infi_le α at h3,
  apply h3 ε h2 h1,
end

lemma ennreal.infi_prop_le_elim (P:Prop) (x:ennreal):
(⨅ (hp:P), x) < ⊤ → P :=
begin
  intro h1,
  cases classical.em P with h2 h2,
  apply h2,
  rw infi_prop_false at h1,
  simp at h1,
  apply false.elim h1,
  apply h2,
end

lemma ennreal.add_pos_of_pos {x y:ennreal}:(0 < y) → (0 < x + y) :=
begin
  intros h,
  apply lt_of_lt_of_le h,
  rw add_comm,
  apply ennreal.le_add,
  apply le_refl _,
end

--Replace with one_div
lemma ennreal.one_div (x:ennreal):1/x = x⁻¹ := begin
  simp,
end

lemma ennreal.coe_infi {α:Sort*} [nonempty α] {f:α → nnreal}:
  @coe nnreal ennreal _ (⨅ i, f i) = (⨅ i,  @coe nnreal ennreal _ (f i)) := begin
  simp only [infi],
  rw ennreal.coe_Inf,
  apply le_antisymm,
  { simp, intros a, apply @infi_le_of_le ennreal nnreal _ _ _ (f a),
    apply @infi_le_of_le ennreal α _ _ _ a,
    rw infi_pos, apply le_refl _, refl },
  { simp, intros a, apply @Inf_le ennreal _ _ _,
    simp, apply exists.intro a, refl },
  apply set.range_nonempty,
end

lemma ennreal.coe_supr {α:Sort*} [nonempty α] {f:α → nnreal}:
  (bdd_above (set.range f)) →
  @coe nnreal ennreal _ (⨆ i, f i) = (⨆ i,  @coe nnreal ennreal _ (f i)) := begin
  intros h1,
  simp only [supr],
  rw ennreal.coe_Sup,
  apply le_antisymm,
  { simp, intros a, apply @le_Sup ennreal _ _ _,
    simp, apply exists.intro a, refl },
  { simp, intros a, apply @le_supr_of_le ennreal nnreal _ _ _ (f a),
    apply @le_supr_of_le ennreal α _ _ _ a,
    rw supr_pos, apply le_refl _, refl },
  apply h1,
end

/- These are tricky to place, because they depend upon ennreal. -/

lemma nnreal.mul_infi {ι:Sort*} [nonempty ι] {f : ι → nnreal} {x : nnreal}  :
  x * infi f = ⨅i, x * f i :=
begin
  rw ← ennreal.coe_eq_coe,
  rw ennreal.coe_mul,
  rw ennreal.coe_infi,
  rw ennreal.mul_infi,
  rw ennreal.coe_infi,
  have h1:(λ i, @coe nnreal ennreal _ (x * f i)) = (λ i, (↑ x) * (↑ (f i))),
  { ext1 i, rw ennreal.coe_mul },
  rw h1,
  simp,
end

lemma nnreal.mul_supr {ι:Sort*} [nonempty ι] {f : ι → nnreal} {x : nnreal}
  (h:bdd_above (set.range f))  :
  x * supr f = ⨆i, x * f i :=
begin
  rw ← ennreal.coe_eq_coe,
  rw ennreal.coe_mul,
  rw ennreal.coe_supr,
  rw ennreal.mul_supr,

  rw ennreal.coe_supr,
  have h1:(λ i, @coe nnreal ennreal _ (x * f i)) = (λ i, (↑ x) * (↑ (f i))),
  { ext1 i, rw ennreal.coe_mul },
  rw h1,
  { simp [bdd_above], rw set.nonempty_def,
    simp [bdd_above] at h,
    rw set.nonempty_def at h,
    cases h with y h,
    rw mem_upper_bounds at h,
    apply exists.intro (x * y),
    rw mem_upper_bounds,
    intros z h_z,
    simp at h_z,
    cases h_z with i h_z,
    subst z,
    have h_mem:(f i) ∈ set.range f,
    { simp },
    have h_z' := h (f i) h_mem,

    apply mul_le_mul,
    apply le_refl _,
    apply h_z',
    simp,
    simp },
  { apply h },
end