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

notation, basic datatypes and type classes
-/
import Mathlib.PrePort

universes u l v w u_1 u_2 u₁ u₂ u₃

namespace Mathlib

/- Reserving notation. We do this so that the precedence of all of the operators
can be seen in one place and to prevent core notation being accidentally overloaded later.  -/

/- Notation for logical operations and relations -/

/- types and type constructors -/

/- arithmetic operations -/

/- boolean operations -/

/- set operations -/

/- other symbols -/

/--
The kernel definitional equality test (t =?= s) has special support for id_delta applications.
It implements the following rules

   1)   (id_delta t) =?= t
   2)   t =?= (id_delta t)
   3)   (id_delta t) =?= s  IF (unfold_of t) =?= s
   4)   t =?= id_delta s    IF t =?= (unfold_of s)

This is mechanism for controlling the delta reduction (aka unfolding) used in the kernel.

We use id_delta applications to address performance problems when type checking
lemmas generated by the equation compiler.
-/
def id_delta {α : Sort u} (a : α) : α := a

/-- Gadget for optional parameter support. -/
def opt_param (α : Sort u) (default : α) := α

/-- Gadget for marking output parameters in type classes. -/
def out_param (α : Sort u) := α

/-
  id_rhs is an auxiliary declaration used in the equation compiler to address performance
  issues when proving equational lemmas. The equation compiler uses it as a marker.
-/

def id_rhs (α : Sort u) (a : α) : α := a

not found

/-- An abbreviation for `punit.{0}`, its most common instantiation.
    This type should be preferred over `punit` where possible to avoid
    unnecessary universe parameters. -/
def unit := PUnit

def unit.star : Unit := PUnit.unit

/--
Gadget for defining thunks, thunk parameters have special treatment.
Example: given
      def f (s : string) (t : thunk nat) : nat
an application
     f "hello" 10
 is converted into
     f "hello" (λ _, 10)
-/
def thunk (α : Type u) := Unit → α

not found

not found

inductive empty where

/--
Logical not.

`not P`, with notation `¬ P`, is the `Prop` which is true if and only if `P` is false. It is
internally represented as `P → false`, so one way to prove a goal `⊢ ¬ P` is to use `intro h`,
which gives you a new hypothesis `h : P` and the goal `⊢ false`.

A hypothesis `h : ¬ P` can be used in term mode as a function, so if `w : P` then `h w : false`.

Related mathlib tactic: `contrapose`.
-/
def not (a : Prop) := a → False

prefix:40 "¬" => Mathlib.not

not found

/-
Initialize the quotient module, which effectively adds the following definitions:

constant quot {α : Sort u} (r : α → α → Prop) : Sort u

constant quot.mk {α : Sort u} (r : α → α → Prop) (a : α) : quot r

constant quot.lift {α : Sort u} {r : α → α → Prop} {β : Sort v} (f : α → β) :
  (∀ a b : α, r a b → eq (f a) (f b)) → quot r → β

constant quot.ind {α : Sort u} {r : α → α → Prop} {β : quot r → Prop} :
  (∀ a : α, β (quot.mk r a)) → ∀ q : quot r, β q

Also the reduction rule:

quot.lift f _ (quot.mk a) ~~> f a

-/

/--
Heterogeneous equality.

Its purpose is to write down equalities between terms whose types are not definitionally equal.
For example, given `x : vector α n` and `y : vector α (0+n)`, `x = y` doesn't typecheck but `x == y` does.

If you have a goal `⊢ x == y`,
your first instinct should be to ask (either yourself, or on [zulip](https://leanprover.zulipchat.com/))
if something has gone wrong already.
If you really do need to follow this route,
you may find the lemmas `eq_rec_heq` and `eq_mpr_heq` useful.
-/
not found

not found

/-- Similar to `prod`, but α and β can be propositions.
   We use this type internally to automatically generate the brec_on recursor. -/
not found

/--
Logical and.

`and P Q`, with notation `P ∧ Q`, is the `Prop` which is true precisely when `P` and `Q` are
both true.

To prove a goal `⊢ P ∧ Q`, you can use the tactic `split`,
which gives two separate goals `⊢ P` and `⊢ Q`.

Given a hypothesis `h : P ∧ Q`, you can use the tactic `cases h with hP hQ`
to obtain two new hypotheses `hP : P` and `hQ : Q`. See also the `obtain` or `rcases` tactics in
mathlib.
-/
not found

def and.elim_left {a : Prop} {b : Prop} (h : a ∧ b) : a := and.left h

def and.elim_right {a : Prop} {b : Prop} (h : a ∧ b) : b := and.right h

infixl:50 " = " => Mathlib.eq

/- eq basic support -/

def rfl {α : Sort u} {a : α} : a = a := Eq.refl a

theorem eq.subst {α : Sort u} {P : α → Prop} {a : α} {b : α} (h₁ : a = b) (h₂ : P a) : P b :=
  Eq._oldrec h₂ h₁

infixr:75 " ▸ " => Mathlib.eq.subst

theorem eq.trans {α : Sort u} {a : α} {b : α} {c : α} (h₁ : a = b) (h₂ : b = c) : a = c := h₂ ▸ h₁

theorem eq.symm {α : Sort u} {a : α} {b : α} (h : a = b) : b = a := h ▸ rfl

infixl:50 " == " => Mathlib.heq

def heq.rfl {α : Sort u} {a : α} : a == a := HEq.refl a

theorem eq_of_heq {α : Sort u} {a : α} {a' : α} (h : a == a') : a = a' :=
  (fun (this : ∀ (α' : Sort u) (a' : α'), a == a' → ∀ (h₂ : α = α'), eq.rec_on h₂ a = a') =>
      (fun (this : eq.rec_on (Eq.refl α) a = a') => this) (this α a' h (Eq.refl α)))
    fun (α' : Sort u) (a' : α') (h₁ : a == a') => heq.rec_on h₁ fun (h₂ : α = α) => rfl

/- The following four lemmas could not be automatically generated when the
   structures were declared, so we prove them manually here. -/

theorem prod.mk.inj {α : Type u} {β : Type v} {x₁ : α} {y₁ : β} {x₂ : α} {y₂ : β} :
    (x₁, y₁) = (x₂, y₂) → x₁ = x₂ ∧ y₁ = y₂ :=
  fun (h : (x₁, y₁) = (x₂, y₂)) =>
    prod.no_confusion h fun (h₁ : x₁ = x₂) (h₂ : y₁ = y₂) => { left := h₁, right := h₂ }

theorem prod.mk.inj_arrow {α : Type u} {β : Type v} {x₁ : α} {y₁ : β} {x₂ : α} {y₂ : β} :
    (x₁, y₁) = (x₂, y₂) → {P : Sort w} → (x₁ = x₂ → y₁ = y₂ → P) → P :=
  fun (h₁ : (x₁, y₁) = (x₂, y₂)) (_x : Sort w) (h₂ : x₁ = x₂ → y₁ = y₂ → _x) =>
    prod.no_confusion h₁ h₂

theorem pprod.mk.inj {α : Sort u} {β : Sort v} {x₁ : α} {y₁ : β} {x₂ : α} {y₂ : β} :
    { fst := x₁, snd := y₁ } = { fst := x₂, snd := y₂ } → x₁ = x₂ ∧ y₁ = y₂ :=
  fun (h : { fst := x₁, snd := y₁ } = { fst := x₂, snd := y₂ }) =>
    pprod.no_confusion h fun (h₁ : x₁ = x₂) (h₂ : y₁ = y₂) => { left := h₁, right := h₂ }

theorem pprod.mk.inj_arrow {α : Type u} {β : Type v} {x₁ : α} {y₁ : β} {x₂ : α} {y₂ : β} :
    (x₁, y₁) = (x₂, y₂) → {P : Sort w} → (x₁ = x₂ → y₁ = y₂ → P) → P :=
  fun (h₁ : (x₁, y₁) = (x₂, y₂)) (_x : Sort w) (h₂ : x₁ = x₂ → y₁ = y₂ → _x) =>
    prod.no_confusion h₁ h₂

inductive sum (α : Type u) (β : Type v) where
| inl : α → sum α β
| inr : β → sum α β

inductive psum (α : Sort u) (β : Sort v) where
| inl : α → psum α β
| inr : β → psum α β

/--
Logical or.

`or P Q`, with notation `P ∨ Q`, is the proposition which is true if and only if `P` or `Q` is
true.

To prove a goal `⊢ P ∨ Q`, if you know which alternative you want to prove,
you can use the tactics `left` (which gives the goal `⊢ P`)
or `right` (which gives the goal `⊢ Q`).

Given a hypothesis `h : P ∨ Q` and goal `⊢ R`,
the tactic `cases h` will give you two copies of the goal `⊢ R`,
with the hypothesis `h : P` in the first, and the hypothesis `h : Q` in the second.
-/
not found

def or.intro_left {a : Prop} (b : Prop) (ha : a) : a ∨ b := Or.inl ha

def or.intro_right (a : Prop) {b : Prop} (hb : b) : a ∨ b := Or.inr hb

structure sigma {α : Type u} (β : α → Type v) where
  fst : α
  snd : β fst

structure psigma {α : Sort u} (β : α → Sort v) where
  fst : α
  snd : β fst

not found

/- Remark: subtype must take a Sort instead of Type because of the axiom strong_indefinite_description. -/

not found

not found

def decidable_pred {α : Sort u} (r : α → Prop) := (a : α) → Decidable (r a)

def decidable_rel {α : Sort u} (r : α → α → Prop) := (a b : α) → Decidable (r a b)

def decidable_eq (α : Sort u) := DecidableRel Eq

not found

not found

infixr:67 " :: " => Mathlib.list.cons

not found

structure unification_constraint where
  α : Type u
  lhs : α
  rhs : α

infixl:50 " ≟ " => Mathlib.unification_constraint.mk

infixl:50 " =?= " => Mathlib.unification_constraint.mk

structure unification_hint where
  pattern : unification_constraint
  constraints : List unification_constraint

/- Declare builtin and reserved notation -/

not found

not found

not found

not found

class has_inv (α : Type u) where
  inv : α → α

not found

not found

not found

class has_dvd (α : Type u) where
  dvd : α → α → Prop

not found

not found

not found

not found

class has_andthen (α : Type u) (β : Type v) (σ : outParam (Type w)) where
  andthen : α → β → σ

class has_union (α : Type u) where
  union : α → α → α

class has_inter (α : Type u) where
  inter : α → α → α

class has_sdiff (α : Type u) where
  sdiff : α → α → α

class has_equiv (α : Sort u) where
  equiv : α → α → Prop

class has_subset (α : Type u) where
  subset : α → α → Prop

/- Type classes has_emptyc and has_insert are
class has_ssubset (α : Type u) where
  ssubset : α → α → Prop

   used to implement polymorphic notation for collections.
   Example: {a, b, c}. -/

class has_emptyc (α : Type u) where
  emptyc : α

class has_insert (α : outParam (Type u)) (γ : Type v) where
  insert : α → γ → γ

/- Type class used to implement the notation { a ∈ c | p a } -/

class has_singleton (α : outParam (Type u)) (β : Type v) where
  singleton : α → β

class has_sep (α : outParam (Type u)) (γ : Type v) where
  sep : (α → Prop) → γ → γ

/- Type class for set-like membership -/

class has_mem (α : outParam (Type u)) (γ : Type v) where
  mem : α → γ → Prop

class has_pow (α : Type u) (β : Type v) where
  pow : α → β → α

infixl:50 " ∈ " => Mathlib.has_mem.mem

infixl:65 " + " => Mathlib.has_add.add

infixl:70 " * " => Mathlib.has_mul.mul

infixl:65 " - " => Mathlib.has_sub.sub

infixl:70 " / " => Mathlib.has_div.div

infixl:50 " ∣ " => Mathlib.has_dvd.dvd

infixl:70 " % " => Mathlib.has_mod.mod

prefix:75 "-" => Mathlib.has_neg.neg

infixl:50 " <= " => Mathlib.has_le.le

infixl:50 " ≤ " => Mathlib.has_le.le

infixl:50 " < " => Mathlib.has_lt.lt

infixl:65 " ++ " => Mathlib.has_append.append

infixl:1 "; " => Mathlib.has_andthen.andthen

notation:1024 "∅" => Mathlib.has_emptyc.emptyc

infixl:65 " ∪ " => Mathlib.has_union.union

infixl:70 " ∩ " => Mathlib.has_inter.inter

infixl:50 " ⊆ " => Mathlib.has_subset.subset

infixl:50 " ⊂ " => Mathlib.has_ssubset.ssubset

infixl:70 " \ " => Mathlib.has_sdiff.sdiff

infixl:50 " ≈ " => Mathlib.has_equiv.equiv

infixr:80 " ^ " => Mathlib.has_pow.pow

def ge {α : Type u} [HasLessEq α] (a : α) (b : α) := b ≤ a

def gt {α : Type u} [HasLess α] (a : α) (b : α) := b < a

infixl:50 " >= " => Mathlib.ge

infixl:50 " ≥ " => Mathlib.ge

infixl:50 " > " => Mathlib.gt

def superset {α : Type u} [has_subset α] (a : α) (b : α) := b ⊆ a

def ssuperset {α : Type u} [has_ssubset α] (a : α) (b : α) := b ⊂ a

infixl:50 " ⊇ " => Mathlib.superset

infixl:50 " ⊃ " => Mathlib.ssuperset

def bit0 {α : Type u} [s : Add α] (a : α) : α := a + a

def bit1 {α : Type u} [s₁ : HasOne α] [s₂ : Add α] (a : α) : α := bit0 a + 1

class is_lawful_singleton (α : Type u) (β : Type v) [has_emptyc β] [has_insert α β]
    [has_singleton α β]
    where
  insert_emptyc_eq : ∀ (x : α), insert x ∅ = has_singleton.singleton x

/- nat basic instances -/

namespace nat

protected def add : Nat → Nat → Nat := Nat.add

end nat

protected instance nat.has_zero : HasZero Nat := { zero := 0 }

protected instance nat.has_one : HasOne Nat := { one := 1 }

protected instance nat.has_add : Add Nat := { add := Nat.add }

def std.priority.default : Nat := bit0 (bit0 (bit0 (bit1 (bit0 (bit1 (bit1 (bit1 (bit1 1))))))))

def std.priority.max : Nat :=
  bit1
    (bit1
      (bit1
        (bit1
          (bit1
            (bit1
              (bit1
                (bit1
                  (bit1
                    (bit1
                      (bit1
                        (bit1
                          (bit1
                            (bit1
                              (bit1
                                (bit1
                                  (bit1
                                    (bit1
                                      (bit1
                                        (bit1
                                          (bit1
                                            (bit1
                                              (bit1
                                                (bit1
                                                  (bit1
                                                    (bit1
                                                      (bit1
                                                        (bit1
                                                          (bit1
                                                            (bit1
                                                              (bit1 1))))))))))))))))))))))))))))))

namespace nat

end nat

protected def nat.prio : Nat := std.priority.default + bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))

/-
  Global declarations of right binding strength

  If a module reassigns these, it will be incompatible with other modules that adhere to these
  conventions.

  When hovering over a symbol, use "C-c C-k" to see how to input it.
-/

def std.prec.max : Nat := bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 (bit0 1)))))))))

def std.prec.arrow : Nat := bit1 (bit0 (bit0 (bit1 1)))

/-
The next def is "max + 10". It can be used e.g. for postfix operations that should
be stronger than application.
-/

def std.prec.max_plus : Nat := std.prec.max + bit0 (bit1 (bit0 1))

postfix:0 "⁻¹" => Mathlib.has_inv.inv

infixr:35 " × " => Mathlib.prod

-- notation for n-ary tuples

/- sizeof -/

not found

def sizeof {α : Sort u} [s : SizeOf α] : α → Nat := has_sizeof.sizeof

/-
Declare sizeof instances and lemmas for types declared before has_sizeof.
From now on, the inductive compiler will automatically generate sizeof instances and lemmas.
-/

/- Every type `α` has a default has_sizeof instance that just returns 0 for every element of `α` -/

protected def default.sizeof (α : Sort u) : α → Nat := sorry

protected instance default_has_sizeof (α : Sort u) : SizeOf α := { sizeOf := default.sizeof α }

protected def nat.sizeof : Nat → Nat := sorry

protected instance nat.has_sizeof : SizeOf Nat := { sizeOf := nat.sizeof }

protected def prod.sizeof {α : Type u} {β : Type v} [SizeOf α] [SizeOf β] : α × β → Nat := sorry

protected instance prod.has_sizeof (α : Type u) (β : Type v) [SizeOf α] [SizeOf β] :
    SizeOf (α × β) :=
  { sizeOf := prod.sizeof }

protected def sum.sizeof {α : Type u} {β : Type v} [SizeOf α] [SizeOf β] : sum α β → Nat := sorry

protected instance sum.has_sizeof (α : Type u) (β : Type v) [SizeOf α] [SizeOf β] :
    SizeOf (sum α β) :=
  { sizeOf := sum.sizeof }

protected def psum.sizeof {α : Type u} {β : Type v} [SizeOf α] [SizeOf β] : psum α β → Nat := sorry

protected instance psum.has_sizeof (α : Type u) (β : Type v) [SizeOf α] [SizeOf β] :
    SizeOf (psum α β) :=
  { sizeOf := psum.sizeof }

protected def sigma.sizeof {α : Type u} {β : α → Type v} [SizeOf α] [(a : α) → SizeOf (β a)] :
    sigma β → Nat :=
  sorry

protected instance sigma.has_sizeof (α : Type u) (β : α → Type v) [SizeOf α]
    [(a : α) → SizeOf (β a)] : SizeOf (sigma β) :=
  { sizeOf := sigma.sizeof }

protected def psigma.sizeof {α : Type u} {β : α → Type v} [SizeOf α] [(a : α) → SizeOf (β a)] :
    psigma β → Nat :=
  sorry

protected instance psigma.has_sizeof (α : Type u) (β : α → Type v) [SizeOf α]
    [(a : α) → SizeOf (β a)] : SizeOf (psigma β) :=
  { sizeOf := psigma.sizeof }

protected def punit.sizeof : PUnit → Nat := sorry

protected instance punit.has_sizeof : SizeOf PUnit := { sizeOf := punit.sizeof }

protected def bool.sizeof : Bool → Nat := sorry

protected instance bool.has_sizeof : SizeOf Bool := { sizeOf := bool.sizeof }

protected def option.sizeof {α : Type u} [SizeOf α] : Option α → Nat := sorry

protected instance option.has_sizeof (α : Type u) [SizeOf α] : SizeOf (Option α) :=
  { sizeOf := option.sizeof }

protected def list.sizeof {α : Type u} [SizeOf α] : List α → Nat := sorry

protected instance list.has_sizeof (α : Type u) [SizeOf α] : SizeOf (List α) :=
  { sizeOf := list.sizeof }

protected def subtype.sizeof {α : Type u} [SizeOf α] {p : α → Prop} : Subtype p → Nat := sorry

protected instance subtype.has_sizeof {α : Type u} [SizeOf α] (p : α → Prop) : SizeOf (Subtype p) :=
  { sizeOf := subtype.sizeof }

theorem nat_add_zero (n : Nat) : n + 0 = n := rfl

/- Combinator calculus -/

namespace combinator

def I {α : Type u₁} (a : α) : α := a

def K {α : Type u₁} {β : Type u₂} (a : α) (b : β) : α := a

end combinator

def combinator.S {α : Type u₁} {β : Type u₂} {γ : Type u₃} (x : α → β → γ) (y : α → β) (z : α) :
    γ :=
  x z (y z)

/-- Auxiliary datatype for #[ ... ] notation.
    #[1, 2, 3, 4] is notation for

    bin_tree.node
      (bin_tree.node (bin_tree.leaf 1) (bin_tree.leaf 2))
      (bin_tree.node (bin_tree.leaf 3) (bin_tree.leaf 4))

    We use this notation to input long sequences without exhausting the system stack space.
    Later, we define a coercion from `bin_tree` into `list`.
-/
inductive bin_tree (α : Type u) where
| empty : bin_tree α
| leaf : α → bin_tree α
| node : bin_tree α → bin_tree α → bin_tree α

/- Basic unification hints -/

def add_succ_defeq_succ_add_hint (x : Nat) (y : Nat) (z : Nat) : unification_hint :=
  unification_hint.mk (x + Nat.succ y =?= Nat.succ z) [z =?= x + y]

/-- Like `by apply_instance`, but not dependent on the tactic framework. -/
def infer_instance {α : Sort u} [i : α] : α := i

end Mathlib


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

import category_theory.category
import abelian
import abelian_SEMF
import exact
import tactic.diagram_chase

open category_theory
open category_theory.limits
open category_theory.abelian
open category_theory.abelian.pseudoelements

namespace category_theory.abelian.diagram_lemmas.snake

universes v u
variables (V : Type u) [𝒞 : category.{v} V] [abelian.{v} V]
include 𝒞

structure snake_diagram :=
(A B C D E F G H I J K L : V)
(α : A ⟶ B) (β : B ⟶ C) (γ : A ⟶ D) (δ : B ⟶ E) (ε : C ⟶ F)
(ζ : D ⟶ E) (η : E ⟶ F) (θ : D ⟶ G) (κ : E ⟶ H) (μ : F ⟶ I)
(ν : G ⟶ H) (ξ : H ⟶ I) (π : G ⟶ J) (ρ : H ⟶ K) (σ : I ⟶ L)
(τ : J ⟶ K) (φ : K ⟶ L)

structure exact_snake_diagram extends snake_diagram.{v} V :=
(comm₁ : α ≫ δ = γ ≫ ζ) (comm₂ : β ≫ ε = δ ≫ η) (comm₃ : ζ ≫ κ = θ ≫ ν)
(comm₄ : η ≫ μ = κ ≫ ξ) (comm₅ : ν ≫ ρ = π ≫ τ) (comm₆ : ξ ≫ σ = ρ ≫ φ)
--(αβ : exact α β)
(ζη : exact ζ η) (νξ : exact ν ξ)
--(τφ : exact τ φ)
(γθ : exact γ θ)
(θπ : exact θ π) (δκ : exact δ κ) (κρ : exact κ ρ) (εμ : exact ε μ) (μσ : exact μ σ)

attribute [chase] exact_snake_diagram.comm₁ exact_snake_diagram.comm₂ exact_snake_diagram.comm₃
attribute [chase] exact_snake_diagram.comm₄ exact_snake_diagram.comm₅ exact_snake_diagram.comm₆
--attribute [chase] exact_snake_diagram.αβ
attribute [chase] exact_snake_diagram.ζη exact_snake_diagram.νξ
--attribute [chase] exact_snake_diagram.τφ
attribute [chase] exact_snake_diagram.γθ exact_snake_diagram.θπ
attribute [chase] exact_snake_diagram.δκ exact_snake_diagram.κρ exact_snake_diagram.εμ
attribute [chase] exact_snake_diagram.μσ

variable {V}

/- We need to do this instead of `attribute [chase] snake_digram.α` because the projection
   has the wrong signature: It takes a `snake_diagram` instead of an `exact_snake_diagram`. -/
@[chase] abbreviation exact_snake_α (d : exact_snake_diagram.{v} V) := d.α
@[chase] abbreviation exact_snake_β (d : exact_snake_diagram.{v} V) := d.β
@[chase] abbreviation exact_snake_γ (d : exact_snake_diagram.{v} V) := d.γ
@[chase] abbreviation exact_snake_δ (d : exact_snake_diagram.{v} V) := d.δ
@[chase] abbreviation exact_snake_ε (d : exact_snake_diagram.{v} V) := d.ε
@[chase] abbreviation exact_snake_ζ (d : exact_snake_diagram.{v} V) := d.ζ
@[chase] abbreviation exact_snake_η (d : exact_snake_diagram.{v} V) := d.η
@[chase] abbreviation exact_snake_θ (d : exact_snake_diagram.{v} V) := d.θ
@[chase] abbreviation exact_snake_κ (d : exact_snake_diagram.{v} V) := d.κ
@[chase] abbreviation exact_snake_μ (d : exact_snake_diagram.{v} V) := d.μ
@[chase] abbreviation exact_snake_ν (d : exact_snake_diagram.{v} V) := d.ν
@[chase] abbreviation exact_snake_ξ (d : exact_snake_diagram.{v} V) := d.ξ
@[chase] abbreviation exact_snake_π (d : exact_snake_diagram.{v} V) := d.π
@[chase] abbreviation exact_snake_ρ (d : exact_snake_diagram.{v} V) := d.ρ
@[chase] abbreviation exact_snake_σ (d : exact_snake_diagram.{v} V) := d.σ
@[chase] abbreviation exact_snake_τ (d : exact_snake_diagram.{v} V) := d.τ
@[chase] abbreviation exact_snake_φ (d : exact_snake_diagram.{v} V) := d.φ

--set_option profiler true

namespace restricted

namespace internal
variable (d : exact_snake_diagram.{v} V)
variables [mono d.ζ] [epi d.ξ] [epi d.η] [mono d.ν] [mono d.ε] [epi d.π]

local attribute [instance] object_to_sort
local attribute [instance] hom_to_fun

abbreviation Z : V := pullback d.ε d.η
abbreviation Δ : (Z d) ⟶ d.C := pullback.fst
abbreviation Γ : (Z d) ⟶ d.E := pullback.snd
@[chase] lemma comm₇ : (Δ d) ≫ d.ε = (Γ d) ≫ d.η := pullback.condition

abbreviation Y : V := pushout d.π d.ν
abbreviation Ξ : d.J ⟶ (Y d) := pushout.inl
abbreviation Λ : d.H ⟶ (Y d) := pushout.inr
@[chase] lemma comm₈ : d.π ≫ (Ξ d) = d.ν ≫ (Λ d) := pushout.condition

abbreviation X : V := kernel (Δ d)
abbreviation S : (X d) ⟶ (Z d) := kernel.ι (Δ d)

def W := cokernel (Ξ d)
def Υ := cokernel.π (Ξ d)

@[chase] lemma SΔ : exact (S d) (Δ d) := kernel_exact _
@[chase] lemma ΞΥ : exact (Ξ d) (Υ d) := cokernel_exact _

lemma SΓη : (S d ≫ Γ d) ≫ d.η = 0 :=
begin
  rw category.assoc,
  ext,
  simp only [comp_apply],
  commutativity at d,
end

def HΨ := kernel_fork.is_limit.lift' (kernel_of_mono_exact _ _ d.ζη) (S d ≫ Γ d) (SΓη d)
def Ψ : (X d) ⟶ d.D := (HΨ d).1
@[chase] lemma hΨ : Ψ d ≫ d.ζ = S d ≫ Γ d := (HΨ d).2

lemma νΛΥ : d.ν ≫ (Λ d) ≫ (Υ d) = 0 :=
begin
  ext,
  simp only [comp_apply],
  commutativity at d,
end

def HΩ := cokernel_cofork.is_colimit.desc' (cokernel_of_epi_exact _ _ d.νξ) (Λ d ≫ Υ d) (νΛΥ d)
def Ω : d.I ⟶ (W d) := (HΩ d).1
@[chase] lemma hΩ : d.ξ ≫ (Ω d) = (Λ d) ≫ (Υ d) := (HΩ d).2

lemma SΓκΛ : S d ≫ Γ d ≫ d.κ ≫ Λ d = 0 :=
begin
  ext,
  simp only [comp_apply],
  commutativity at d,
end

def Δcone : cokernel_cofork (S d) := cokernel_cofork.of_π (Δ d) $ kernel.condition _
def Δlim : is_colimit (Δcone d) := epi_is_cokernel_of_kernel
  (limit.cone (parallel_pair (Δ d) 0)) (limit.is_limit _)

def Hχ := cokernel_cofork.is_colimit.desc' (Δlim d) _ (SΓκΛ d)
def χ : d.C ⟶ (Y d) := (Hχ d).1
@[chase] lemma hχ : (Δ d) ≫ (χ d) = (Γ d) ≫ d.κ ≫ (Λ d) := (Hχ d).2

lemma Υχ : (χ d) ≫ (Υ d) = 0 :=
begin
  apply (preadditive.cancel_zero_iff_epi (Δ d)).1 (by apply_instance),
  ext,
  simp only [comp_apply],
  commutativity at d,
end

def Ξcone : kernel_fork (Υ d) := kernel_fork.of_ι (Ξ d) $ cokernel.condition _
def Ξlim : is_limit (Ξcone d) := mono_is_kernel_of_cokernel
  (colimit.cocone (parallel_pair (Ξ d) 0)) (colimit.is_colimit _)

def Hω := kernel_fork.is_limit.lift' (Ξlim d) _ (Υχ d)
def ω : d.C ⟶ d.J := (Hω d).1
@[chase] lemma hω : (ω d) ≫ (Ξ d) = (χ d) := (Hω d).2

lemma ω_char (c : d.C) (e : d.E) (g : d.G) (h₁ : d.η e = d.ε c) (h₂ : d.ν g = d.κ e) :
  d.π g = (ω d) c :=
begin
  obtain ⟨z, hz₁, hz₂⟩ := pseudo_pullback h₁.symm,
  change (Δ d : Z d ⟶ d.C) z = c at hz₁,
  change (Γ d : Z d → d.E) z = e at hz₂,
  apply pseudo_injective_of_mono (Ξ d),
  commutativity at d,
end

theorem βω : exact d.β (ω d) :=
begin
  apply exact_of_pseudo_exact,
  split,
  { intro b,
    chase b using [d.β] with c,
    chase b using [d.δ] with e,
    have h₁ : d.η e = d.ε c, by commutativity at d,
    chase e using [d.κ, d.ν] with h g at d,
    have : d.ν g = 0, by commutativity at d,
    have : g = 0, -- This should be automatic!
    { apply pseudo_injective_of_mono d.ν,
      commutativity at d, },
    have h₂ : d.ν g = d.κ e, by commutativity,
    have := ω_char d _ _ _ h₁ h₂,
    commutativity, },
  { intros c hc,
    chase c using [d.ε, d.η, d.κ, d.ν] with f e h g at d,
    have := ω_char _ c e g (by commutativity) (by commutativity),
    chase g using [d.θ] with d' at d,
    have : d.κ (d.ζ d') = d.κ e, by commutativity at d,
    obtain ⟨z, hz₁, hz₂⟩ := sub_of_eq_image _ _ _ this.symm,
    chase z using [d.δ] with b at d,
    have : d.η (d.ζ d') = 0, by commutativity at d,
    have := hz₂ _ _ this,
    use b,
    apply pseudo_injective_of_mono d.ε, -- This should also be automatic
    commutativity at d, }
end

theorem ωτ : exact (ω d) d.τ :=
begin
  apply exact_of_pseudo_exact,
  split,
  { intro c,
    chase c using [d.ε, d.η, d.κ, d.ν] with f e h g at d,
    have := ω_char _ c e g (by commutativity) (by commutativity),
    commutativity at d, },
  { intros j hj,
    chase j using [d.π, d.ν, d.κ, d.η, d.ε] with g h e f c at d,
    have := ω_char _ c e g (by commutativity) (by commutativity),
    exact ⟨c, by commutativity⟩ }
end

end internal

variable (d : exact_snake_diagram.{v} V)
variables [mono d.ζ] [epi d.ξ] [epi d.η] [mono d.ν] [mono d.ε] [epi d.π]

def connecting_morphism : d.C ⟶ d.J :=
internal.ω d

theorem exact₁ : exact d.β (connecting_morphism d) :=
internal.βω d

theorem exact₂ : exact (connecting_morphism d) d.τ :=
internal.ωτ d

end restricted

namespace internal
variable (d : exact_snake_diagram.{v} V)
variables [mono d.ν] [epi d.η] [mono d.δ] [mono d.ε] [epi d.π] [epi d.ρ]

local attribute [instance] object_to_sort
local attribute [instance] hom_to_fun

abbreviation Z : V := kernel (cokernel.π d.ζ)
@[chase] abbreviation ζ₁ : d.D ⟶ (Z d) := factor_thru_image d.ζ
@[chase] abbreviation ζ₂ : (Z d) ⟶ d.E := kernel.ι (cokernel.π d.ζ)

instance strong_epi_ζ : strong_epi (ζ₁ d) :=
strong_epi_of_epi _

@[chase] abbreviation Γ : (Z d) ⟶ d.G := diag_lift $
  show d.θ ≫ (𝟙 d.G ≫ d.ν) = (ζ₁ d ≫ ζ₂ d) ≫ d.κ, from
  begin
    rw abelian.image.fac,
    rw category.id_comp,
    exact d.comm₃.symm,
  end

@[chase] lemma hΓ₁ : (ζ₁ d) ≫ (Γ d) = d.θ :=
begin
  rw diag_lift_fac_left,
  rw category.comp_id
end

@[chase] lemma hΓ₂ : (ζ₂ d) ≫ d.κ = (Γ d) ≫ d.ν :=
eq.symm $ diag_lift_fac_right _

abbreviation W : V := kernel (cokernel.π d.ξ)
abbreviation ξ₁ : d.H ⟶ (W d) := factor_thru_image d.ξ
abbreviation ξ₂ : (W d) ⟶ d.I := kernel.ι (cokernel.π d.ξ)

instance strong_epi_ξ : strong_epi (ξ₁ d) :=
strong_epi_of_epi _

instance strong_epi_η : strong_epi d.to_snake_diagram.η :=
strong_epi_of_epi _

@[chase] def Δ : d.F ⟶ (W d) :=
diag_lift $ show d.κ ≫ (ξ₁ d ≫ ξ₂ d) = (d.η ≫ 𝟙 d.F) ≫ d.μ, from
begin
  erw abelian.image.fac d.ξ,
  rw category.assoc,
  rw category.id_comp,
  exact d.comm₄.symm
end

@[chase] lemma hΔ₁ : d.η ≫ (Δ d) = d.κ ≫ (ξ₁ d) :=
diag_lift_fac_left _

@[chase] lemma hΔ₂ : d.μ = (Δ d) ≫ (ξ₂ d) :=
begin
  rw ←category.id_comp d.μ,
  exact (diag_lift_fac_right _).symm
end

abbreviation V' : V := kernel (Γ d)
abbreviation Λ : (V' d) ⟶ (Z d) := kernel.ι (Γ d)

abbreviation U : V := kernel (Δ d)
abbreviation Ξ : (U d) ⟶ d.F := kernel.ι (Δ d)

abbreviation T : V := cokernel (Γ d)
abbreviation S : d.G ⟶ (T d) := cokernel.π (Γ d)

abbreviation S' : V := cokernel (Δ d)
abbreviation Υ : (W d) ⟶ (S' d) := cokernel.π (Δ d)

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

abbreviation Hα₁ := kernel.lift' (Γ d) (d.γ ≫ (ζ₁ d)) $
  by rw [category.assoc, hΓ₁, d.γθ.1]
abbreviation α₁ : d.A ⟶ (V' d) := (Hα₁ d).1
@[chase] lemma hα₁ : α₁ d ≫ Λ d = d.γ ≫ (ζ₁ d) := (Hα₁ d).2

abbreviation Hα₂ := kernel_fork.is_limit.lift' (kernel_of_mono_exact _ _ d.δκ) (Λ d ≫ ζ₂ d) $
  by rw [category.assoc, hΓ₂, ←category.assoc, kernel.condition, has_zero_morphisms.zero_comp]
abbreviation α₂ : V' d ⟶ d.B := (Hα₂ d).1
@[chase] lemma hα₂ : α₂ d ≫ d.δ = Λ d ≫ ζ₂ d := (Hα₂ d).2

abbreviation Hβ₁ := kernel.lift' (Δ d) (d.δ ≫ d.η) $
  by rw [category.assoc, hΔ₁, ←category.assoc, d.δκ.1, has_zero_morphisms.zero_comp]
abbreviation β₁ : d.B ⟶ (U d) := (Hβ₁ d).1
@[chase] lemma hβ₁ : β₁ d ≫ Ξ d = d.δ ≫ d.η := (Hβ₁ d).2

abbreviation Hβ₂ := kernel_fork.is_limit.lift' (kernel_of_mono_exact _ _ d.εμ) (Ξ d) $
  by rw [hΔ₂, ←category.assoc, kernel.condition, has_zero_morphisms.zero_comp]
abbreviation β₂ : U d ⟶ d.C := (Hβ₂ d).1
@[chase] lemma hβ₂ : β₂ d ≫ d.ε = Ξ d := (Hβ₂ d).2

lemma β₁β₂ : β₁ d ≫ β₂ d = d.β :=
begin
  apply fork.is_limit.hom_ext (kernel_of_mono_exact _ _ d.εμ),
  erw [category.assoc, hβ₂, hβ₁, d.comm₂]
end

abbreviation Hτ₁ := cokernel_cofork.is_colimit.desc' (cokernel_of_epi_exact _ _ d.θπ) (S d) $
  by rw [←hΓ₁, category.assoc, cokernel.condition, has_zero_morphisms.comp_zero]
abbreviation τ₁ : d.J ⟶ (T d) := (Hτ₁ d).1
@[chase] lemma hτ₁ : d.π ≫ (τ₁ d) = S d := (Hτ₁ d).2

abbreviation Hτ₂ := cokernel.desc' (Γ d) (d.ν ≫ d.ρ) $
  by rw [←category.assoc, ←hΓ₂, category.assoc, d.κρ.1, has_zero_morphisms.comp_zero]
abbreviation τ₂ : T d ⟶ d.K := (Hτ₂ d).1
@[chase] lemma hτ₂ : S d ≫ τ₂ d = d.ν ≫ d.ρ := (Hτ₂ d).2

lemma τ₁τ₂ : τ₁ d ≫ τ₂ d = d.τ :=
begin
  apply cofork.is_colimit.hom_ext (cokernel_of_epi_exact _ _ d.θπ),
  erw [←category.assoc, hτ₁, hτ₂, ←d.comm₅]
end

abbreviation Hφ₁ := cokernel_cofork.is_colimit.desc' (cokernel_of_epi_exact _ _ d.κρ) (ξ₁ d ≫ Υ d) $
  by rw [←category.assoc, ←hΔ₁, category.assoc, cokernel.condition, has_zero_morphisms.comp_zero]
abbreviation φ₁ : d.K ⟶ S' d := (Hφ₁ d).1
@[chase] lemma hφ₁ : d.ρ ≫ φ₁ d = ξ₁ d ≫ Υ d := (Hφ₁ d).2

@[chase] lemma ΞΔ : exact (Ξ d) (Δ d) := kernel_exact _
@[chase] lemma ΓS : exact (Γ d) (S d) := cokernel_exact _

instance β₂_mono : mono (β₂ d) :=
mono_of_mono_fac $ hβ₂ d

instance β₂_epi : epi (β₂ d) :=
begin
  apply epi_of_pseudo_surjective,
  intro c,
  chase c using [d.ε] with f,
  have : (Δ d : _ ⟶ _) f = 0,
  { apply pseudo_injective_of_mono (ξ₂ d),
    rw ←comp_apply,
    rw ←hΔ₂,
    rw ←h.f,
    rw ←comp_apply,
    rw d.εμ.1,
    rw zero_apply,
    rw apply_zero, },
  chase f using [Ξ d] with u at d,
  use u,
  apply pseudo_injective_of_mono d.ε,
  commutativity at d,
end

instance β₂_iso : is_iso (β₂ d) :=
mono_epi_iso _

instance τ₁_epi : epi (τ₁ d) :=
epi_of_epi_fac $ hτ₁ d

instance τ₁_mono : mono (τ₁ d) :=
begin
  apply mono_of_zero_of_map_zero,
  intros j hj,
  chase j using [d.π] with g at d,
  have : (S d : _ ⟶ _) g = 0,
  { rw [←hτ₁, comp_apply, h.g, hj], },
  chase g using [Γ d] with z at d,
  obtain ⟨e, he⟩ := pseudo_surjective_of_epi (ζ₁ d) z,
  rw [←h.g, ←h.z, ←he, ←comp_apply, ←comp_apply, ←category.assoc, hΓ₁, d.θπ.1, zero_apply],
end

instance τ₁_iso : is_iso (τ₁ d) :=
mono_epi_iso _

abbreviation inner_diagram : exact_snake_diagram.{v} V :=
{ A := V' d, B := d.B, C := U d, D := Z d, E := d.E, F := d.F,
  G := d.G, H := d.H, I := W d, J := T d, K := d.K, L := S' d,
  α := α₂ d,
  β := β₁ d,
  γ := Λ d,
  δ := d.δ,
  ε := Ξ d,
  ζ := ζ₂ d,
  η := d.η,
  θ := Γ d,
  κ := d.κ,
  μ := Δ d,
  ν := d.ν,
  ξ := ξ₁ d,
  π := S d,
  ρ := d.ρ,
  σ := Υ d,
  τ := τ₂ d,
  φ := φ₁ d,
  comm₁ := hα₂ d,
  comm₂ := hβ₁ d,
  comm₃ := hΓ₂ d,
  comm₄ := hΔ₁ d,
  comm₅ := (hτ₂ d).symm,
  comm₆ := (hφ₁ d).symm,
  ζη := image_exact _ _ d.ζη,
  νξ := exact_image _ _ d.νξ,
  γθ := kernel_exact _,
  θπ := cokernel_exact _,
  δκ := d.δκ,
  κρ := d.κρ,
  εμ := kernel_exact _,
  μσ := cokernel_exact _ }

abbreviation ω' : U d ⟶ T d := restricted.connecting_morphism (inner_diagram d)

abbreviation ω : d.C ⟶ d.J := inv (β₂ d) ≫ ω' d ≫ inv (τ₁ d)

lemma βω : exact d.β (ω d) :=
begin
  have : exact (β₁ d) (ω' d) := restricted.exact₁ (inner_diagram d),
  have := exact_iso_right _ _ (as_iso (inv (τ₁ d))) this,
  have : exact (β₁ d ≫ β₂ d) (ω d) := exact_iso _ _ (as_iso (β₂ d)) this,
  rw β₁β₂ at this,
  exact this,
end

lemma ωτ : exact (ω d) (d.τ) :=
begin
  have := restricted.exact₂ (inner_diagram d),
  have := exact_iso _ _ (as_iso (inv (τ₁ d))) this,
  have : exact (ω d) (τ₁ d ≫ τ₂ d) := exact_iso_left _ _ (as_iso (inv (β₂ d))) this,
  rw τ₁τ₂ at this,
  exact this,
end

end internal

variable (d : exact_snake_diagram.{v} V)
variables [mono d.ν] [epi d.η] [mono d.δ] [mono d.ε] [epi d.π] [epi d.ρ]

def connecting_morphism : d.C ⟶ d.J :=
internal.ω d

theorem exact₁ : exact d.β (connecting_morphism d) :=
internal.βω d

theorem exact₂ : exact (connecting_morphism d) d.τ :=
internal.ωτ d

end category_theory.abelian.diagram_lemmas.snake


import tactic.auto_cases
import tactic.tidy
import tactic.with_local_reducibility
import tactic.show_term
import rpartrec

section
variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*} {σ : Type*} {τ : Type*} {μ : Type*} {o_dom : Type*} {o_cod : Type*}
  [primcodable α] [primcodable β] [primcodable γ] [primcodable δ] [primcodable σ] [primcodable τ] [primcodable μ] [primcodable o_dom] [primcodable o_cod]
  {o : o_dom →. o_cod}
open rcomputable rcomputable₂

#check option.get_or_else

theorem rcomputable.unpaired3 {f : β → γ → δ → σ} {g : α → β} {h : α → γ} {i : α → δ}
  (hf : (prod.unpaired3 f) computable_in o)
  (hg : g computable_in o) (hh : h computable_in o) (hi : i computable_in o) :
  (λ a : α, f (g a) (h a) (i a)) computable_in o :=
hf.comp (hg.pair (hh.pair hi))

lemma rcomputable.option_get_or_else {f : α → option β} {g : α → β}
  (hf : f computable_in o) (hg : g computable_in o) : (λ x, option.get_or_else (f x) (g x)) computable_in o :=
rcomputable₂.comp (computable.option_get_or_else computable.fst computable.snd).to_rcomp hf hg

lemma rcomputable.option_some : (option.some : α → option α) computable_in o :=
computable.option_some.to_rcomp

lemma rcomputable.option_is_some : (option.is_some : option α → bool) computable_in o :=
primrec.option_is_some.to_rcomp

lemma rcomputable.option_iget [inhabited α] : (option.iget : option α → α) computable_in o :=
primrec.option_iget.to_rcomp

lemma rcomputable₂.list_rnth : (@list.rnth α) computable₂_in o :=
(primrec.list_nth.comp (primrec.list_reverse.comp primrec.fst) primrec.snd).to_rcomp

lemma rcomputable.option_or_else :
  ((<|>) : option β → option β → option β) computable₂_in o :=
primrec.option_orelse.to_rcomp

lemma rcomputable₂.to_bool_eq (α : Type*) [primcodable α] [decidable_eq α] :
  (λ x y : α, to_bool (x = y)) computable₂_in o := primrec.eq.to_rcomp

lemma rcomputable.to_bool_eq (β : Type*) [primcodable β] [decidable_eq β]
  {f : α → β} {g : α → β} (hf : f computable_in o) (hg : g computable_in o) :
  (λ a : α, to_bool (f a = g a)) computable_in o := (rcomputable₂.to_bool_eq β).comp hf hg

lemma rcomputable₂.to_bool_nat_lt : (λ m n : ℕ, to_bool (m < n)) computable₂_in o := primrec.nat_lt.to_rcomp

lemma rcomputable₂.to_bool_nat_le : (λ m n : ℕ, to_bool (m ≤ n)) computable₂_in o := primrec.nat_le.to_rcomp

lemma rcomputable.succ : nat.succ computable_in o := primrec.succ.to_rcomp

lemma rcomputable.pred : nat.pred computable_in o := primrec.pred.to_rcomp

lemma rcomputable₂.nat_add : ((+) : ℕ → ℕ → ℕ) computable₂_in o := primrec.nat_add.to_rcomp

lemma rcomputable₂.nat_sub : (has_sub.sub : ℕ → ℕ → ℕ) computable₂_in o := primrec.nat_sub.to_rcomp

lemma rcomputable₂.nat_mul : ((*) : ℕ → ℕ → ℕ) computable₂_in o := primrec.nat_mul.to_rcomp

lemma rcomputable₂.nat_min : (min : ℕ → ℕ → ℕ) computable₂_in o := primrec.nat_min.to_rcomp

lemma rcomputable₂.nat_max : (max : ℕ → ℕ → ℕ) computable₂_in o := primrec.nat_max.to_rcomp

lemma rcomputable₂.nat_mkpair : (nat.mkpair : ℕ → ℕ → ℕ) computable₂_in o := primrec₂.mkpair.to_rcomp

lemma rcomputable.nat_unpaired : (nat.unpair : ℕ → ℕ × ℕ) computable_in o := primrec.unpair.to_rcomp

lemma rcomputable.nat_div2 : (nat.div2 : ℕ → ℕ) computable_in o := primrec.nat_div2.to_rcomp

lemma rcomputable.nat_bodd : nat.bodd computable_in o := primrec.nat_bodd.to_rcomp

lemma rcomputable.dom_fintype [fintype α] (f : α → β) : f computable_in o := (primrec.dom_fintype f).to_rcomp

protected lemma rcomputable.bnot : bnot computable_in o := primrec.bnot.to_rcomp

protected lemma rcomputable.band : band computable₂_in o := primrec.band.to_rcomp

protected lemma rcomputable.bor : bor computable₂_in o := primrec.bor.to_rcomp

@[protected]
lemma rcomputable.ite {c : α → Prop} [decidable_pred c] {f g : α → β}
  (hc : (λ x, to_bool (c x)) computable_in o) (hf : f computable_in o) (hg : g computable_in o):
  (λ a, if c a then f a else g a) computable_in o :=
(rcomputable.cond hc hf hg).of_eq (λ x, by by_cases C : c x; simp[C])

lemma rcomputable₂.list_cons : (list.cons : α → list α → list α) computable₂_in o := primrec.list_cons.to_rcomp

lemma rcomputable₂.list_nth : (list.nth : list α → ℕ → option α) computable₂_in o := primrec.list_nth.to_rcomp

lemma rcomputable₂.list_append : ((++) : list α → list α → list α) computable₂_in o := primrec.list_append.to_rcomp

lemma rcomputable.list_length : (list.length : list α → ℕ) computable_in o := primrec.list_length.to_rcomp

#check @list.rec

protected lemma rcomputable.of_nat (α : Type*) [denumerable α] : (denumerable.of_nat α) computable_in o :=
(primrec.of_nat α).to_rcomp

lemma rcomputable.option_get {f : α → option β} {h : ∀ a, (f a).is_some}
  (hf : f computable_in o) : (λ a, option.get (h a)) computable_in o :=
((rpartrec.nat_iff1.mp rcomputable.pred).comp hf).of_eq (λ n,
  by { simp,
       generalize hx : encodable.decode α n = x,
       cases x; simp,
       rcases C : f x,
       { exfalso, have := h x, simp[C] at this, contradiction },
       { simp[C] } })

lemma rcomputable.list_range_r : list.range_r computable_in o :=
begin
  have : (nat.elim [] (λ m IH, m :: IH)) computable_in o,
  { refine rcomputable.nat_elim' rcomputable.id (rcomputable.const [])
    (rcomputable₂.list_cons.comp rcomputable.fst.to_unary₂ rcomputable.snd.to_unary₂) },
  exact this.of_eq (λ n, by { induction n with n IH; simp[list.range_r], exact IH })
end

theorem rcomputable.option_rec {f : α → option β} {g : α → γ} {h : α → β → γ}
  (hf : f computable_in o) (hg : g computable_in o) (hh : h computable₂_in o) :
  @rcomputable _ _ γ _ _ _ _ _ (λ a, option.rec (g a) (h a) (f a)) o :=
rcomputable.option_cases hf hg hh

lemma rcomputable.computable_of_rcomp {f : α → β} (hf : f computable_in! computable_fun) :
  computable f := rpartrec.le_part_part hf computable.computable_fun

lemma rpartrec.partrec_of_rpart {f : α →. β} (hf : f partrec_in! computable_fun) :
  partrec f := rpartrec.le_part_part hf computable.computable_fun

end

@[user_attribute]
meta def rcomputability : user_attribute :=
{ name := `rcomputability,
  descr := "lemmas usable to prove relative computability" }

attribute [rcomputability]
  rcomputable.id
  rcomputable.id'
  rcomputable.fst
  rcomputable.snd
  rcomputable.pair
  rcomputable.const
  rcomputable.encode
  rcomputable.decode
  rcomputable.refl
  rcomputable.cond
  rcomputable.ite
  rcomputable.succ
  rcomputable.pred
  rcomputable.of_nat
  rcomputable.nat_cases
  rcomputable.option_cases
  rcomputable.option_rec
  rcomputable.option_bind
  rcomputable.option_map
  rcomputable.option_some
  rcomputable.option_is_some
  rcomputable.option_get_or_else
  rcomputable.option_or_else
  rcomputable.option_get
  rcomputable.option_iget
  rcomputable.nat_bodd
  rcomputable.dom_fintype
  rcomputable₂.list_cons
  rcomputable₂.list_nth
  rcomputable₂.list_append
  rcomputable.list_length
  rcomputable.list_range_r
  rcomputable₂.to_bool_eq
  rcomputable.to_bool_eq
  rcomputable₂.to_bool_nat_lt
  rcomputable₂.to_bool_nat_le
  rcomputable₂.pair
  rcomputable₂.list_rnth
  rcomputable₂.nat_add
  rcomputable₂.nat_sub
  rcomputable₂.nat_mul
  rcomputable₂.nat_min
  rcomputable₂.nat_max
  rcomputable₂.nat_mkpair
  rcomputable.nat_unpaired
  rcomputable.nat_div2
  rcomputable.bnot
  rcomputable.band
  rcomputable.bor

  rpartrec.refl
  rpartrec.of_option
  rpartrec.of_option'
  rpartrec.coe
  rpartrec.some
  rpartrec.bind
  rpartrec.map
  rpartrec.rfind
  rpartrec.rfind_opt

open tactic.interactive («have»)
open tactic (get_local infer_type)

namespace tactic
namespace interactive

setup_tactic_parser

meta def goal_is_partrec : tactic unit := do t ← tactic.target,
  match t with
  | `(partrec %%r) := skip
  | _              := failed
  end

meta def goal_is_computable : tactic unit := do t ← tactic.target,
  match t with
  | `(computable %%r) := skip
  | _                 := failed
  end

meta def goal_is_rpartrec : tactic unit := do t ← tactic.target,
  match t with
  | `(rpartrec %%l %%r)     := skip
  | `(rpartrec_tot %%l %%r) := skip
  | _ := failed
  end

meta def goal_is_rcomputable : tactic unit := do t ← tactic.target,
  match t with
  | `(rcomputable %%l %%r)     := skip
  | `(rcomputable_tot %%l %%r) := skip
  | _ := failed
  end

meta def goal_is_rpartrec₂ : tactic unit := do t ← tactic.target,
  match t with
  | `(rpartrec₂ %%l %%r)     := skip
  | `(rpartrec₂_tot %%l %%r) := skip
  | _ := failed
  end

meta def goal_is_rcomputable₂ : tactic unit := do t ← tactic.target,
  match t with
  | `(rcomputable₂ %%l %%r)     := skip
  | `(rcomputable₂_tot %%l %%r) := skip
  | _ := failed
  end

meta def rcomputability_tactics (md : transparency := semireducible) : list (tactic string) :=
[ propositional_goal >> apply_assumption >> pure "apply_assumption",
  goal_is_partrec >> `[refine rpartrec.partrec_of_rpart _] >> pure "refine rpartrec.partrec_of_rpart _",
  goal_is_computable >> `[refine rcomputable.computable_of_rcomp _] >> pure "refine rcomputable.computable_of_rcomp _",
  apply_rules [``(rcomputability)] 50 { md := md } >> pure "apply_rules rcomputability",
  `[refine rcomputable.to_unary₁ _]  >> pure "refine rcomputable.to_unary₁ _",
  `[refine rcomputable.to_unary₂ _]  >> pure "refine rcomputable.to_unary₂ _",
  `[refine rpartrec.to_unary₁ _]     >> pure "refine rpartrec.to_unary₁ _",
  `[refine rpartrec.to_unary₂ _]     >> pure "refine rpartrec.to_unary₂ _",
  goal_is_rcomputable₂ >> `[refine rcomputable₂.comp₂ _ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rcomputable₂.comp₂ _ _ _",
  goal_is_rcomputable  >> `[refine rcomputable₂.comp _ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rcomputable₂.comp _ _ _",
  goal_is_rpartrec₂    >> `[refine rpartrec₂.comp₂ _ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rpartrec₂.comp₂ _ _ _",
  goal_is_rpartrec     >> `[refine rpartrec₂.comp _ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rpartrec₂.comp _ _ _",
  goal_is_rcomputable₂ >> `[refine rcomputable.comp₂ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rcomputable.comp₂ _ _",
  goal_is_rcomputable  >> `[refine rcomputable.comp _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rcomputable.comp _ _",
  goal_is_rpartrec     >> `[refine rpartrec.comp _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rpartrec.comp _ _",
  goal_is_rpartrec₂    >> `[refine rpartrec.comp₂ _ _; try { exact rpartrec.some };
    fail_if_success { exact rcomputable.id }] >> pure "refine rpartrec.comp₂ _ _" ]

meta def rcomputability
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md                  := if bang.is_some then semireducible else reducible,
    rcomputability_core := tactic.tidy { tactics := rcomputability_tactics md, ..cfg },
    trace_fn            := if trace.is_some then show_term else id in
trace_fn rcomputability_core
end interactive

end tactic

open encodable

variables {α : Type*} {β : Type*} {γ : Type*} {σ : Type*} {τ : Type*}
  [primcodable α] [primcodable β] [primcodable γ] [primcodable σ] [primcodable τ] {o : σ →. τ}

example (f : ℕ →. ℕ) (p : ℕ → ℕ →. bool) (h : p partrec₂_in f) :
  (λ x : ℕ, (nat.rfind (p x)).map (λ y, (y, (y, 0, x)))) partrec_in f :=
by { rcomputability }

example {f : α → ℕ → option σ} {g : β →. τ}(hf : f computable₂_in g) :
  (λ (a : α), ↑(λ (n : ℕ), (f a n).is_some) : α → ℕ →. bool) partrec₂_in g :=
by { unfold_coes, simp[pfun.lift],
     rcomputability }


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.algebra.group.defs
import Mathlib.algebra.group.hom
import Mathlib.logic.embedding
import Mathlib.PostPort

universes u v l u_1 u_2 u_3 w

namespace Mathlib

/-!
# Definitions of group actions

This file defines a hierarchy of group action type-classes:

* `has_scalar α β`
* `mul_action α β`
* `distrib_mul_action α β`

The hierarchy is extended further by `semimodule`, defined elsewhere.

Also provided are type-classes regarding the interaction of different group actions,

* `smul_comm_class M N α`
* `is_scalar_tower M N α`

## Notation

`a • b` is used as notation for `smul a b`.

## Implementation details

This file should avoid depending on other parts of `group_theory`, to avoid import cycles.
More sophisticated lemmas belong in `group_theory.group_action`.
-/

/-- Typeclass for types with a scalar multiplication operation, denoted `•` (`\bu`) -/
class has_scalar (α : Type u) (γ : Type v) where
  smul : α → γ → γ

infixr:73 " • " => Mathlib.has_scalar.smul

/-- Typeclass for multiplicative actions by monoids. This generalizes group actions. -/
class mul_action (α : Type u) (β : Type v) [monoid α] extends has_scalar α β where
  one_smul : ∀ (b : β), 1 • b = b
  mul_smul : ∀ (x y : α) (b : β), (x * y) • b = x • y • b

/-- A typeclass mixin saying that two actions on the same space commute. -/
class smul_comm_class (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M α] [has_scalar N α]
    where
  smul_comm : ∀ (m : M) (n : N) (a : α), m • n • a = n • m • a

/-- Commutativity of actions is a symmetric relation. This lemma can't be an instance because this
would cause a loop in the instance search graph. -/
theorem smul_comm_class.symm (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M α]
    [has_scalar N α] [smul_comm_class M N α] : smul_comm_class N M α :=
  smul_comm_class.mk fun (a' : N) (a : M) (b : α) => Eq.symm (smul_comm a a' b)

protected instance smul_comm_class_self (M : Type u_1) (α : Type u_2) [comm_monoid M]
    [mul_action M α] : smul_comm_class M M α :=
  smul_comm_class.mk
    fun (a a' : M) (b : α) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (a • a' • b = a' • a • b)) (Eq.symm (mul_smul a a' b))))
        (eq.mpr (id (Eq._oldrec (Eq.refl ((a * a') • b = a' • a • b)) (mul_comm a a')))
          (eq.mpr (id (Eq._oldrec (Eq.refl ((a' * a) • b = a' • a • b)) (mul_smul a' a b)))
            (Eq.refl (a' • a • b))))

/-- An instance of `is_scalar_tower M N α` states that the multiplicative
action of `M` on `α` is determined by the multiplicative actions of `M` on `N`
and `N` on `α`. -/
class is_scalar_tower (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M N] [has_scalar N α]
    [has_scalar M α]
    where
  smul_assoc : ∀ (x : M) (y : N) (z : α), (x • y) • z = x • y • z

@[simp] theorem smul_assoc {α : Type u} {M : Type u_1} {N : Type u_2} [has_scalar M N]
    [has_scalar N α] [has_scalar M α] [is_scalar_tower M N α] (x : M) (y : N) (z : α) :
    (x • y) • z = x • y • z :=
  is_scalar_tower.smul_assoc x y z

theorem smul_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (a₁ : α) (a₂ : α) (b : β) :
    a₁ • a₂ • b = (a₁ * a₂) • b :=
  Eq.symm (mul_smul a₁ a₂ b)

@[simp] theorem one_smul (α : Type u) {β : Type v} [monoid α] [mul_action α β] (b : β) :
    1 • b = b :=
  mul_action.one_smul b

/-- Pullback a multiplicative action along an injective map respecting `•`. -/
protected def function.injective.mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α]
    [mul_action α β] [has_scalar α γ] (f : γ → β) (hf : function.injective f)
    (smul : ∀ (c : α) (x : γ), f (c • x) = c • f x) : mul_action α γ :=
  mul_action.mk sorry sorry

/-- Pushforward a multiplicative action along a surjective map respecting `•`. -/
protected def function.surjective.mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α]
    [mul_action α β] [has_scalar α γ] (f : β → γ) (hf : function.surjective f)
    (smul : ∀ (c : α) (x : β), f (c • x) = c • f x) : mul_action α γ :=
  mul_action.mk sorry sorry

theorem ite_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (p : Prop) [Decidable p]
    (a₁ : α) (a₂ : α) (b : β) : ite p a₁ a₂ • b = ite p (a₁ • b) (a₂ • b) :=
  sorry

theorem smul_ite {α : Type u} {β : Type v} [monoid α] [mul_action α β] (p : Prop) [Decidable p]
    (a : α) (b₁ : β) (b₂ : β) : a • ite p b₁ b₂ = ite p (a • b₁) (a • b₂) :=
  sorry

namespace mul_action

/-- The regular action of a monoid on itself by left multiplication. -/
def regular (α : Type u) [monoid α] : mul_action α α := mk sorry sorry

protected instance is_scalar_tower.left (α : Type u) {β : Type v} [monoid α] [mul_action α β] :
    is_scalar_tower α α β :=
  is_scalar_tower.mk fun (x y : α) (z : β) => mul_smul x y z

/-- Embedding induced by action. -/
def to_fun (α : Type u) (β : Type v) [monoid α] [mul_action α β] : β ↪ α → β :=
  function.embedding.mk (fun (y : β) (x : α) => x • y) sorry

@[simp] theorem to_fun_apply {α : Type u} {β : Type v} [monoid α] [mul_action α β] (x : α) (y : β) :
    coe_fn (to_fun α β) y x = x • y :=
  rfl

/-- An action of `α` on `β` and a monoid homomorphism `γ → α` induce an action of `γ` on `β`. -/
def comp_hom {α : Type u} (β : Type v) {γ : Type w} [monoid α] [mul_action α β] [monoid γ]
    (g : γ →* α) : mul_action γ β :=
  mk sorry sorry

end mul_action

@[simp] theorem smul_one_smul {α : Type u} {M : Type u_1} (N : Type u_2) [monoid N] [has_scalar M N]
    [mul_action N α] [has_scalar M α] [is_scalar_tower M N α] (x : M) (y : α) :
    (x • 1) • y = x • y :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((x • 1) • y = x • y)) (smul_assoc x 1 y)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (x • 1 • y = x • y)) (one_smul N y))) (Eq.refl (x • y)))

/-- Typeclass for multiplicative actions on additive structures. This generalizes group modules. -/
class distrib_mul_action (α : Type u) (β : Type v) [monoid α] [add_monoid β] extends mul_action α β
    where
  smul_add : ∀ (r : α) (x y : β), r • (x + y) = r • x + r • y
  smul_zero : ∀ (r : α), r • 0 = 0

theorem smul_add {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β]
    (a : α) (b₁ : β) (b₂ : β) : a • (b₁ + b₂) = a • b₁ + a • b₂ :=
  distrib_mul_action.smul_add a b₁ b₂

@[simp] theorem smul_zero {α : Type u} {β : Type v} [monoid α] [add_monoid β]
    [distrib_mul_action α β] (a : α) : a • 0 = 0 :=
  distrib_mul_action.smul_zero a

/-- Pullback a distributive multiplicative action along an injective additive monoid
homomorphism. -/
protected def function.injective.distrib_mul_action {α : Type u} {β : Type v} {γ : Type w}
    [monoid α] [add_monoid β] [distrib_mul_action α β] [add_monoid γ] [has_scalar α γ] (f : γ →+ β)
    (hf : function.injective ⇑f) (smul : ∀ (c : α) (x : γ), coe_fn f (c • x) = c • coe_fn f x) :
    distrib_mul_action α γ :=
  distrib_mul_action.mk sorry sorry

/-- Pushforward a distributive multiplicative action along a surjective additive monoid
homomorphism.-/
protected def function.surjective.distrib_mul_action {α : Type u} {β : Type v} {γ : Type w}
    [monoid α] [add_monoid β] [distrib_mul_action α β] [add_monoid γ] [has_scalar α γ] (f : β →+ γ)
    (hf : function.surjective ⇑f) (smul : ∀ (c : α) (x : β), coe_fn f (c • x) = c • coe_fn f x) :
    distrib_mul_action α γ :=
  distrib_mul_action.mk sorry sorry

/-- Scalar multiplication by `r` as an `add_monoid_hom`. -/
def const_smul_hom {α : Type u} (β : Type v) [monoid α] [add_monoid β] [distrib_mul_action α β]
    (r : α) : β →+ β :=
  add_monoid_hom.mk (has_scalar.smul r) (smul_zero r) (smul_add r)

@[simp] theorem const_smul_hom_apply {α : Type u} {β : Type v} [monoid α] [add_monoid β]
    [distrib_mul_action α β] (r : α) (x : β) : coe_fn (const_smul_hom β r) x = r • x :=
  rfl

@[simp] theorem smul_neg {α : Type u} {β : Type v} [monoid α] [add_group β] [distrib_mul_action α β]
    (r : α) (x : β) : r • -x = -(r • x) :=
  sorry

theorem smul_sub {α : Type u} {β : Type v} [monoid α] [add_group β] [distrib_mul_action α β] (r : α)
    (x : β) (y : β) : r • (x - y) = r • x - r • y :=
  sorry

end Mathlib


/-
A universe of bundled setoids, i.e. types with equivalence relations.
This is one of the simplest universes where functoriality is nontrivial. It is essentially the
same as a universe of groupoids where isomorphisms are propositions. Therefore, it is especially
useful as a blueprint for the universe of categories.
There is a truncation functor from every other universe to the setoid universe, and of course this
can be continued into `sort` by taking the quotient.
-/

import UniverseAbstractions.Axioms.Universes
import UniverseAbstractions.Axioms.Universe.Identity
import UniverseAbstractions.Axioms.Universe.Functors
import UniverseAbstractions.Axioms.Universe.FunctorExtensionality
import UniverseAbstractions.Axioms.Universe.Products
import UniverseAbstractions.Axioms.Universe.Equivalences
import UniverseAbstractions.Axioms.Universe.DependentTypes.Properties
import UniverseAbstractions.Axioms.Universe.DependentTypes.DependentFunctors
import UniverseAbstractions.Axioms.Universe.DependentTypes.DependentProducts
import UniverseAbstractions.Instances.Utils.Bundled
import UniverseAbstractions.Instances.Utils.Trivial
import UniverseAbstractions.Instances.Sort

set_option autoBoundImplicitLocal false
set_option synthInstance.maxHeartbeats 4000
--set_option pp.universes true

universe u v w w' upv

namespace Setoid

  open Bundled MetaRelation HasFunctors HasCongrArg HasCongrFun HasLinearFunOp HasPropCongrArg

  def typeClass : SimpleTypeClass.{u, max 1 u} := Setoid.{u}
  @[reducible] def univ : Universe.{u, u + 1} := Bundled.univ typeClass.{u}
  @[reducible] def tuniv := univ.{max 1 u}

  instance inst (A : univ.{u}) : Setoid.{u} A := A.inst

  def lift {α : Sort u} {ω : Sort w} (s : Setoid α) (l : ω → α) :
    Setoid ω :=
  { r     := λ a b => l a ≈ l b,
    iseqv := { refl  := λ a   => Setoid.refl  (l a),
               symm  := λ h   => Setoid.symm  h,
               trans := λ h i => Setoid.trans h i } }

  -- Instance equivalences

  instance hasEquivalenceRelation (A : univ.{u}) : HasEquivalenceRelation A prop :=
  ⟨nativeRelation (inst A).r⟩

  instance hasInstanceEquivalences : HasInstanceEquivalences univ.{u} prop :=
  ⟨hasEquivalenceRelation⟩

  -- Functors

  def FunctionEquiv {α : Sort u} {φ : α → univ} (f₁ f₂ : ∀ a, φ a) : Prop :=
  ∀ a, f₁ a ≈ f₂ a

  instance functionSetoid {α : Sort u} (φ : α → univ.{v}) :
    Setoid.{imax u v} (∀ a, φ a) :=
  { r     := FunctionEquiv,
    iseqv := { refl  := λ f   a => (inst (φ a)).refl  (f a),
               symm  := λ h   a => (inst (φ a)).symm  (h a),
               trans := λ h i a => (inst (φ a)).trans (h a) (i a) } }

  instance biFunctionSetoid {α : Sort u} {β : Sort v} (φ : α → β → univ.{w}) :
    Setoid.{imax u v w} (∀ a b, φ a b) :=
  inferInstance

  def IsFun {U : Universe} [HasIdentity U] {A : U} {B : univ} (f : A → B) : Prop :=
  ∀ {a₁ a₂ : A}, a₁ ≃ a₂ → f a₁ ≈ f a₂

  instance hasFunctoriality (U : Universe.{u}) [HasIdentity U] :
  HasFunctoriality U univ.{v} := ⟨IsFun⟩

  instance funSetoid {U : Universe.{u}} [HasIdentity U] (A : U) (B : univ.{v}) :
    Setoid.{max 1 u v} (HasFunctoriality.Fun A B) :=
  lift (functionSetoid (Function.const A B)) HasFunctoriality.Fun.f

  instance hasFunctorialityInstances (U : Universe.{u}) [HasIdentity U] :
    HasFunctorialityInstances U univ.{v} typeClass.{max 1 u v} :=
  ⟨funSetoid⟩

  instance hasCongrArg (U : Universe.{u}) [HasIdentity U] : HasCongrArg U univ.{v} :=
  ⟨HasFunctoriality.Fun.isFun⟩

  instance hasCongrFun (U : Universe.{u}) [HasIdentity U] : HasCongrFun U univ.{v} := ⟨id⟩

  instance hasInternalFunctors : HasInternalFunctors tuniv.{u} := ⟨⟩

  def defFun {U : Universe} [HasIdentity U] {A : U} {B : univ} {f : A → B} (isFun : IsFun f) :
    A ⟶{f} B :=
  Bundled.HasFunctorialityInstances.defFun isFun

  instance hasIdFun : HasIdFun univ.{u} := ⟨λ A => defFun id⟩

  instance hasConstFun (U : Universe.{u}) [HasIdentity U] : HasConstFun U univ.{v} :=
  ⟨λ A {B} b => defFun (λ h => Setoid.refl b)⟩

  instance hasRevAppFun : HasRevAppFun tuniv.{u} := ⟨λ a B => defFun (λ h => h a)⟩

  instance hasCompFun (U : Universe.{u}) (V : Universe.{v}) {W : Universe.{w'}} [HasIdentity U]
                      [HasIdentity V] [HasFunctors U V W] [HasCongrArg U V] :
    HasCompFun U V univ.{w} :=
  ⟨λ F G => defFun (λ h => congrArg G (congrArg F h))⟩

  instance hasCompFunFun (U : Universe.{u}) [HasIdentity U] [HasInternalFunctors U] :
    HasCompFunFun U tuniv.{v} :=
                                     -- Work around Lean defeq problem.
  ⟨λ F C => defFun (λ {G₁ G₂} h a => have h₁ : (G₁ ⊙ F).f a = G₁ (F a) := rfl;
                                     have h₂ : (G₂ ⊙ F).f a = G₂ (F a) := rfl;
                                     h₁ ▸ h₂ ▸ h (F a))⟩

  instance hasRevCompFunFun (U : Universe.{u}) [HasIdentity U] [HasInternalFunctors U]
                            [HasCongrFun U U] :
    HasRevCompFunFun U univ.{v} :=
                                           -- Work around Lean defeq problem.
  ⟨λ A {B C} G => defFun (λ {F₁ F₂} e a => have h₁ : (G ⊙ F₁).f a = G (F₁ a) := rfl;
                                           have h₂ : (G ⊙ F₂).f a = G (F₂ a) := rfl;
                                           h₁ ▸ h₂ ▸ congrArg G (congrFun e a))⟩

  instance hasSwapFun (U : Universe.{u}) (V : Universe.{v}) [HasIdentity U] [HasIdentity V] :
    HasSwapFun U V univ.{w} :=
  ⟨λ F b => defFun (λ h => (HasCongrArg.congrArg F h) b)⟩

  instance hasSwapFunFun : HasSwapFunFun univ.{u} univ.{v} univ.{w} :=
                                   -- Work around Lean defeq problem.
  ⟨λ F => defFun (λ {b₁ b₂} h a => have h₁ : (HasSwapFun.swapFun F b₁).f a = F a b₁ := rfl;
                                   have h₂ : (HasSwapFun.swapFun F b₂).f a = F a b₂ := rfl;
                                   h₁ ▸ h₂ ▸ congrArg (F a) h)⟩

  instance hasDupFun (U : Universe.{u}) [HasIdentity U] : HasDupFun U univ.{v} :=
  ⟨λ F => defFun (λ h => congrArg₂ F h h)⟩

  instance hasSubstFun (U : Universe.{u}) (V : Universe.{v}) {W : Universe.{w'}} [HasIdentity U]
                       [HasIdentity V] [HasFunctors U V W] [HasCongrArg U V] :
    HasSubstFun U V univ.{w} :=
  ⟨λ F G => defFun (λ h => congrArg₂ G h (congrArg F h))⟩

  instance hasBiCompFun : HasBiCompFun univ.{u} univ.{v} univ.{w} univ.{w'} :=
  ⟨λ F G H => defFun (λ h => congrArg₂ H (congrArg F h) (congrArg G h))⟩

  instance hasRevBiCompFunFun : HasRevBiCompFunFun tuniv.{u} univ.{v} univ.{w'} :=
                                     -- Work around Lean defeq problem.
  ⟨λ H F => defFun (λ {G₁ G₂} h a => have h₁ : (HasBiCompFun.biCompFun F G₁ H).f a = H (F a) (G₁ a) := rfl;
                                     have h₂ : (HasBiCompFun.biCompFun F G₂ H).f a = H (F a) (G₂ a) := rfl;
                                     h₁ ▸ h₂ ▸ (H (F a)).isFun (h a))⟩

  instance hasRevBiCompFunFunFun : HasRevBiCompFunFunFun tuniv.{u} univ.{w'} :=
                                               -- Work around Lean defeq problem.
  ⟨λ A {B C D} H => defFun (λ {F₁ F₂} h G a => have h₁ : ((HasRevBiCompFunFun.revBiCompFunFun H F₁).f G).f a = H (F₁ a) (G a) := rfl;
                                               have h₂ : ((HasRevBiCompFunFun.revBiCompFunFun H F₂).f G).f a = H (F₂ a) (G a) := rfl;
                                               h₁ ▸ h₂ ▸ (H.isFun (h a)) (G a))⟩

  instance hasLinearFunOp : HasLinearFunOp tuniv.{u} :=
  { defIdFun     := λ A     => defFun id,
    defRevAppFun := λ A B   => ⟨λ a => defFun (λ h => h a),
                                defFun (λ h F => F.isFun h)⟩,
    defCompFun   := λ A B C => ⟨λ F => ⟨λ G => defFun (λ h => G.isFun (F.isFun h)),
                                        defFun (λ h a => h (F a))⟩,
                                defFun (λ h G a => G.isFun (h a))⟩ }

  instance hasAffineFunOp : HasAffineFunOp tuniv.{u} :=
  { defConstFun := λ A B => ⟨λ b => defFun (λ h => Setoid.refl b),
                             defFun (λ h a => h)⟩ }

  instance hasFullFunOp : HasFullFunOp tuniv.{u} :=
  { defDupFun := λ A B => ⟨λ F => defFun (λ h => congrArg₂ F h h),
                           defFun (λ h a => h a a)⟩ }

  instance hasTrivialExtensionality : HasTrivialExtensionality univ.{u} univ.{v} := ⟨id⟩

  instance hasStandardFunctors : HasStandardFunctors tuniv.{u} := ⟨⟩

  -- Setoid truncation from another universe

  def typeSetoid {U : Universe.{u}} [HasIdentity U] (A : U) : Setoid.{u} A :=
  { r     := λ a b => Nonempty (a ≃ b),
    iseqv := { refl  := λ a       => ⟨HasRefl.refl a⟩,
               symm  := λ ⟨e⟩     => ⟨e⁻¹⟩,
               trans := λ ⟨e⟩ ⟨f⟩ => ⟨f • e⟩ } }

  def Truncated {U : Universe.{u}} [HasIdentity U] (A : U) : univ.{u} :=
  { a    := ⌈A⌉,
    inst := typeSetoid A }

  def trunc {U : Universe.{u}} [HasIdentity U] {A : U} (a : A) : Truncated A := a

  def truncFun {U : Universe.{u}} [HasIdentity U] (A : U) : A ⟶ Truncated A :=
  { f     := trunc,
    isFun := λ e => ⟨e⟩ }

  instance trunc.isFunApp {U : Universe.{u}} [HasIdentity U] {A : U} (a : A) :
    IsFunApp A (trunc a) :=
  { F := truncFun A,
    a := a,
    e := Setoid.refl (trunc a) }

  def truncProj {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}} [HasIdentity U]
                [HasIdentity V] [HasIdentity W] [HasFunctors U V W] [HasCongrArg U V]
                {A : U} {B : V} (F : A ⟶ B) :
    Truncated A ⟶ Truncated B :=
  { f     := λ a => F a,
    isFun := λ ⟨e⟩ => ⟨congrArg F e⟩ }

  def truncProjFun {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}} [HasIdentity U]
                   [HasIdentity V] [HasIdentity W] [HasFunctors U V W] [HasCongrArg U V]
                   [HasCongrFun U V] (A : U) (B : V) :
    (A ⟶ B) ⟶ (Truncated A ⟶ Truncated B) :=
  { f     := truncProj,
    isFun := λ e a => ⟨congrFun e a⟩ }

  -- TODO: This fails after a refactoring; no idea why.
  --instance truncProj.isFunApp {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}}
  --                            [HasIdentity U] [HasIdentity V] [HasIdentity W]
  --                            [HasFunctors U V W] [HasCongrArg U V] [HasCongrFun U V]
  --                            {A : U} {B : V} (F : A ⟶ B) :
  --  IsFunApp (A ⟶ B) (truncProj F) :=
  --{ F := truncProjFun A B,
  --  a := F,
  --  e := Setoid.refl (truncProj F) }

  def truncProjFun' {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}} [HasIdentity U]
                    [HasIdentity V] [HasIdentity W] [HasFunctors U V W] [HasCongrArg U V]
                    [HasCongrFun U V] (A : U) (B : V) :
    Truncated (A ⟶ B) ⟶ (Truncated A ⟶ Truncated B) :=
  { f     := truncProj,
    isFun := λ ⟨e⟩ a => ⟨congrFun e a⟩ }

  theorem truncCongr {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}} [HasIdentity U]
                     [HasIdentity V] [HasIdentity W] [HasFunctors U V W] [HasCongrArg U V]
                     {A : U} {B : V} (F : A ⟶ B) (a : A) :
    trunc (F a) ≈ (truncProj F) (trunc a) :=
  ⟨HasRefl.refl (F a)⟩

  theorem truncCongrSquare {U : Universe.{u}} {V : Universe.{v}} {W : Universe.{w}} [HasIdentity U]
                           [HasIdentity V] [HasIdentity W] [HasFunctors U V W] [HasCongrArg U V]
                           {A : U} {B : V} (F : A ⟶ B) :
    truncFun B ⊙ F ≈ truncProj F ⊙ truncFun A :=
  truncCongr F

  -- Setoid to quotient

  def AsQuotient (A : univ.{u}) : sort.{u} := Quotient (inst A)

  def toQuotient {A : univ.{u}} (a : A) : AsQuotient A := Quotient.mk a

  def toQuotientFun (A : univ.{u}) : A ⟶ AsQuotient A :=
  { f        := toQuotient,
    congrArg := Quotient.sound }

  instance toQuotient.isFunApp {A : univ.{u}} (a : A) :
    IsFunApp (V := sort.{u}) A (toQuotient a) :=
  { F := toQuotientFun A,
    a := a,
    e := rfl }

  def quotientProj {A : univ.{u}} {B : univ.{v}} (F : A ⟶ B) : AsQuotient A ⟶ AsQuotient B :=
  -- Work around Lean defeq problem.
  let toQuotB : ⌈B ⟶ AsQuotient B⌉ := toQuotientFun B;
  let G : A ⟶ AsQuotient B := toQuotB ⊙ F;
  Quotient.lift G.f (λ _ _ => G.congrArg)

  def toQuotientCongr {A : univ.{u}} {B : univ.{v}} (F : A ⟶ B) (a : A) :
    toQuotient (F a) = (quotientProj F) (toQuotient a) :=
  rfl

  -- TODO: Seems like another defeq problem together with universe issues.
  --def toQuotientCongrSquare {A : univ.{u}} {B : univ.{v}} (F : A ⟶ B) :
  --  toQuotientFun B ⊙ F = quotientProj F ⊙ toQuotientFun A :=
  --rfl

  -- Singletons

  instance unitSetoid : Setoid.{u} PUnit.{u} :=
  { r     := λ _ _ => True,
    iseqv := { refl  := λ _   => trivial,
               symm  := λ _   => trivial,
               trans := λ _ _ => trivial } }

  instance hasTopInstance : HasTopInstance typeClass.{u} := ⟨unitSetoid⟩

  instance hasTopEq : HasTop.HasTopEq univ.{u} := ⟨λ _ => trivial⟩

  instance hasInternalTop : HasInternalTop tuniv.{u} :=
  { defElimFun := λ a => defFun (λ _ => Setoid.refl a) }

  instance emptySetoid : Setoid.{u} PEmpty.{u} :=
  { r     := λ _ _ => False,
    iseqv := { refl  := PEmpty.elim,
               symm  := id,
               trans := Function.const False } }

  instance hasBotInstance : HasBotInstance typeClass.{u} := ⟨emptySetoid⟩

  instance hasInternalBot : HasInternalBot tuniv.{u} :=
  { defElimFun := λ A => defFun False.elim }

  -- Products

  instance productSetoid (α : Sort u) (β : Sort v) [Setoid α] [Setoid β] :
    Setoid.{max 1 u v} (PProd α β) :=
  { r     := λ p q => p.fst ≈ q.fst ∧ p.snd ≈ q.snd,
    iseqv := { refl  := λ p   => ⟨Setoid.refl  p.fst,         Setoid.refl  p.snd⟩,
               symm  := λ h   => ⟨Setoid.symm  h.left,        Setoid.symm  h.right⟩,
               trans := λ h i => ⟨Setoid.trans h.left i.left, Setoid.trans h.right i.right⟩ } }

  instance prodSetoid (A : univ.{u}) (B : univ.{v}) : Setoid.{max 1 u v} (PProd A B) :=
  productSetoid A B

  instance hasProductInstances : HasProductInstances univ.{u} univ.{v} typeClass.{max 1 u v} :=
  ⟨prodSetoid⟩

  instance hasProductEq : HasProducts.HasProductEq univ.{u} univ.{v} :=
  { introEq := λ p   => Setoid.refl p,
    fstEq   := λ a b => Setoid.refl a,
    sndEq   := λ a b => Setoid.refl b }

  instance hasInternalProducts : HasInternalProducts tuniv.{u} :=
  { defIntroFun := λ A B   => ⟨λ a => defFun (λ h => ⟨Setoid.refl a, h⟩),
                               defFun (λ h b => ⟨h, Setoid.refl b⟩)⟩,
    defElimFun  := λ A B C => ⟨λ F => defFun (λ {p₁ p₂} h => have h_fst : ⌈p₁.fst ≃ p₂.fst⌉ := h.left;
                                                             have h_snd : ⌈p₁.snd ≃ p₂.snd⌉ := h.right;
                                                             congrArg₂ F h_fst h_snd),
                               defFun (λ h p => h p.fst p.snd)⟩ }

  -- Equivalences

  instance equivSetoid (A : univ.{u}) (B : univ.{v}) : Setoid.{max 1 u v} (A ⮂ B) :=
  lift (funSetoid A B) EquivDesc.toFun

  instance hasEquivalenceInstances :
    HasEquivalenceInstances univ.{u} univ.{v} typeClass.{max 1 u v} :=
  { Equiv     := EquivDesc,
    desc      := id,
    equivInst := equivSetoid }

  instance hasInternalEquivalences : HasInternalEquivalences tuniv.{u} :=
  { defToFunFun := λ A B => defFun id,
    isExt       := HasTrivialExtensionality.equivDescExt tuniv.{u},
    toFunInj    := id }

  instance hasTrivialEquivalenceCondition : HasTrivialEquivalenceCondition tuniv.{u} :=
  ⟨λ e => { E        := e,
            toFunEq  := Setoid.refl e.toFun,
            invFunEq := Setoid.refl e.invFun }⟩

  -- Dependent functors

  instance hasTypeIdentity : HasTypeIdentity tuniv.{u} := ⟨⟩

  def IsPi {U : Universe.{u}} {UpV : Universe.{upv}} [HasIdentity U]
           [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}]
           {A : U} {φ : A ⟶ ⌊tuniv.{v}⌋} (f : HasFunctors.Pi φ) :
    Prop :=
  ∀ {a₁ a₂ : A} (e : a₁ ≃ a₂), f a₁ ≃[propCongrArg φ e] f a₂

  instance hasDependentFunctoriality (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
                                     [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}] :
  HasDependentFunctoriality U tuniv.{v} := ⟨IsPi⟩

  instance piSetoid {U : Universe.{u}} {UpV : Universe.{upv}} [HasIdentity U]
                    [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}]
                    {A : U} (φ : A ⟶ ⌊tuniv.{v}⌋) :
    Setoid.{max 1 u v} (HasDependentFunctoriality.Pi φ) :=
  lift (functionSetoid (HasFunctors.apply φ)) HasDependentFunctoriality.Pi.f

  instance hasDependentFunctorialityInstances (U : Universe.{u}) {UpV : Universe.{upv}}
                                              [HasIdentity U] [HasFunctors U {tuniv.{v}} UpV]
                                              [HasPropCongrArg U tuniv.{v}] :
    HasDependentFunctorialityInstances U tuniv.{v} typeClass.{max 1 u v} :=
  ⟨piSetoid⟩

  instance hasDependentCongrArg (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
                                [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}] :
    HasDependentCongrArg U tuniv.{v} :=
  ⟨HasDependentFunctoriality.Pi.isFun⟩

  -- Lean bug :-(
  noncomputable def defInPi {U : Universe.{u}} {UpV : Universe.{upv}} [HasIdentity U]
                            [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}]
                            {A : U} {φ : A ⟶ ⌊tuniv.{v}⌋} (f : HasFunctors.Pi φ) (isFun : IsPi f) :
    Π{f} (HasFunctors.toDefFun φ) :=
  Bundled.HasDependentFunctorialityInstances.defPi isFun

  -- Dependent products

  instance sigmaSetoid {U : Universe.{u}} {UpV : Universe.{upv}} [HasIdentity U]
                       [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}]
                       {A : U} (φ : A ⟶ ⌊tuniv.{v}⌋) :
    Setoid.{max 1 u v} (PSigma (λ a => φ a)) :=
  { r     := λ p₁ p₂ => ∃ e : p₁.fst ≃ p₂.fst, ⌈p₁.snd ≃[propCongrArg φ e] p₂.snd⌉,
    iseqv := { refl  := λ p             => ⟨HasInstanceEquivalences.refl p.fst,
                                            DependentEquivalence.depCongrArgRefl  p.snd⟩,
               symm  := λ ⟨e, h⟩        => ⟨e⁻¹,
                                            DependentEquivalence.depCongrArgSymm  h⟩,
               trans := λ ⟨e, h⟩ ⟨f, i⟩ => ⟨f • e,
                                            DependentEquivalence.depCongrArgTrans h i⟩ } }

  instance hasDependentProductInstances (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
                                        [HasFunctors U {tuniv.{v}} UpV]
                                        [HasPropCongrArg U tuniv.{v}] :
    HasDependentProductInstances U tuniv.{v} typeClass.{max 1 u v} :=
  ⟨sigmaSetoid⟩

  instance hasDependentProducts (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
                                [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}] :
    HasDependentProducts U tuniv.{v} tuniv.{max u v} :=
  Bundled.hasDependentProducts U tuniv.{v}

  instance hasDependentProductEq (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
                                 [HasFunctors U {tuniv.{v}} UpV] [HasPropCongrArg U tuniv.{v}] :
    HasDependentProducts.HasDependentProductEq U tuniv.{v} :=
  { introEq := λ p   => Setoid.refl p,
    fstEq   := λ a b => HasInstanceEquivalences.refl a,
    sndEq   := λ a b => DependentEquivalence.depCongrArgRefl b }

  -- TODO
  --instance hasInternalDependentProducts (U : Universe.{u}) {UpV : Universe.{upv}} [HasIdentity U]
  --                                      [HasFunctors U {tuniv.{u}} UpV] [HasPropCongrArg U tuniv.{u}] :
  --  HasInternalDependentProducts U tuniv.{u} :=
  --sorry

end Setoid


variables {p q : Prop} (hp : p) (hq : q)

include hp hq

example : p ∧ q ∧ p :=
begin
  apply and.intro hp,
  exact and.intro hq hp,
end

omit hp hq

section
include hp hq

example : p ∧ q ∧ p :=
begin
  apply and.intro hp,
  exact and.intro hq hp,
end
end

example : p ∧ q ∧ p :=
let hp := hp, hq := hq in
begin
  apply and.intro hp,
  exact and.intro hq hp
end


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

! This file was ported from Lean 3 source module algebra.category.Algebra.basic
! leanprover-community/mathlib commit 79ffb5563b56fefdea3d60b5736dad168a9494ab
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Algebra.Subalgebra.Basic
import Mathbin.Algebra.FreeAlgebra
import Mathbin.Algebra.Category.Ring.Basic
import Mathbin.Algebra.Category.Module.Basic

/-!
# Category instance for algebras over a commutative ring

We introduce the bundled category `Algebra` of algebras over a fixed commutative ring `R ` along
with the forgetful functors to `Ring` and `Module`. We furthermore show that the functor associating
to a type the free `R`-algebra on that type is left adjoint to the forgetful functor.
-/

open CategoryTheory

open CategoryTheory.Limits

universe v u

variable (R : Type u) [CommRing R]

/-- The category of R-algebras and their morphisms. -/
structure AlgebraCat where
  carrier : Type v
  [isRing : Ring carrier]
  [isAlgebra : Algebra R carrier]
#align Algebra AlgebraCat

attribute [instance] AlgebraCat.isRing AlgebraCat.isAlgebra

namespace AlgebraCat

instance : CoeSort (AlgebraCat R) (Type v) :=
  ⟨AlgebraCat.Carrier⟩

instance : Category (AlgebraCat.{v} R)
    where
  hom A B := A →ₐ[R] B
  id A := AlgHom.id R A
  comp A B C f g := g.comp f

instance : ConcreteCategory.{v} (AlgebraCat.{v} R)
    where
  forget :=
    { obj := fun R => R
      map := fun R S f => (f : R → S) }
  forget_faithful := { }

instance hasForgetToRing : HasForget₂ (AlgebraCat.{v} R) RingCat.{v}
    where forget₂ :=
    { obj := fun A => RingCat.of A
      map := fun A₁ A₂ f => AlgHom.toRingHom f }
#align Algebra.has_forget_to_Ring AlgebraCat.hasForgetToRing

instance hasForgetToModule : HasForget₂ (AlgebraCat.{v} R) (ModuleCat.{v} R)
    where forget₂ :=
    { obj := fun M => ModuleCat.of R M
      map := fun M₁ M₂ f => AlgHom.toLinearMap f }
#align Algebra.has_forget_to_Module AlgebraCat.hasForgetToModule

/-- The object in the category of R-algebras associated to a type equipped with the appropriate
typeclasses. -/
def of (X : Type v) [Ring X] [Algebra R X] : AlgebraCat.{v} R :=
  ⟨X⟩
#align Algebra.of AlgebraCat.of

/-- Typecheck a `alg_hom` as a morphism in `Algebra R`. -/
def ofHom {R : Type u} [CommRing R] {X Y : Type v} [Ring X] [Algebra R X] [Ring Y] [Algebra R Y]
    (f : X →ₐ[R] Y) : of R X ⟶ of R Y :=
  f
#align Algebra.of_hom AlgebraCat.ofHom

@[simp]
theorem ofHom_apply {R : Type u} [CommRing R] {X Y : Type v} [Ring X] [Algebra R X] [Ring Y]
    [Algebra R Y] (f : X →ₐ[R] Y) (x : X) : ofHom f x = f x :=
  rfl
#align Algebra.of_hom_apply AlgebraCat.ofHom_apply

instance : Inhabited (AlgebraCat R) :=
  ⟨of R R⟩

@[simp]
theorem coe_of (X : Type u) [Ring X] [Algebra R X] : (of R X : Type u) = X :=
  rfl
#align Algebra.coe_of AlgebraCat.coe_of

variable {R}

/-- Forgetting to the underlying type and then building the bundled object returns the original
algebra. -/
@[simps]
def ofSelfIso (M : AlgebraCat.{v} R) : AlgebraCat.of R M ≅ M
    where
  hom := 𝟙 M
  inv := 𝟙 M
#align Algebra.of_self_iso AlgebraCat.ofSelfIso

variable {R} {M N U : ModuleCat.{v} R}

@[simp]
theorem id_apply (m : M) : (𝟙 M : M → M) m = m :=
  rfl
#align Algebra.id_apply AlgebraCat.id_apply

@[simp]
theorem coe_comp (f : M ⟶ N) (g : N ⟶ U) : (f ≫ g : M → U) = g ∘ f :=
  rfl
#align Algebra.coe_comp AlgebraCat.coe_comp

variable (R)

/-- The "free algebra" functor, sending a type `S` to the free algebra on `S`. -/
@[simps]
def free : Type u ⥤ AlgebraCat.{u} R
    where
  obj S :=
    { carrier := FreeAlgebra R S
      isRing := Algebra.semiringToRing R }
  map S T f := FreeAlgebra.lift _ <| FreeAlgebra.ι _ ∘ f
  -- obviously can fill the next two goals, but it is slow
  map_id' := by
    intro X
    ext1
    simp only [FreeAlgebra.ι_comp_lift]
    rfl
  map_comp' := by
    intros
    ext1
    simp only [FreeAlgebra.ι_comp_lift]
    ext1
    simp only [FreeAlgebra.lift_ι_apply, CategoryTheory.coe_comp, Function.comp_apply,
      types_comp_apply]
#align Algebra.free AlgebraCat.free

/-- The free/forget adjunction for `R`-algebras. -/
def adj : free.{u} R ⊣ forget (AlgebraCat.{u} R) :=
  Adjunction.mkOfHomEquiv
    { homEquiv := fun X A => (FreeAlgebra.lift _).symm
      -- Relying on `obviously` to fill out these proofs is very slow :(
      homEquiv_naturality_left_symm := by
        intros
        ext
        simp only [free_map, Equiv.symm_symm, FreeAlgebra.lift_ι_apply, CategoryTheory.coe_comp,
          Function.comp_apply, types_comp_apply]
      homEquiv_naturality_right := by
        intros
        ext
        simp only [forget_map_eq_coe, CategoryTheory.coe_comp, Function.comp_apply,
          FreeAlgebra.lift_symm_apply, types_comp_apply] }
#align Algebra.adj AlgebraCat.adj

instance : IsRightAdjoint (forget (AlgebraCat.{u} R)) :=
  ⟨_, adj R⟩

end AlgebraCat

variable {R}

variable {X₁ X₂ : Type u}

/-- Build an isomorphism in the category `Algebra R` from a `alg_equiv` between `algebra`s. -/
@[simps]
def AlgEquiv.toAlgebraIso {g₁ : Ring X₁} {g₂ : Ring X₂} {m₁ : Algebra R X₁} {m₂ : Algebra R X₂}
    (e : X₁ ≃ₐ[R] X₂) : AlgebraCat.of R X₁ ≅ AlgebraCat.of R X₂
    where
  hom := (e : X₁ →ₐ[R] X₂)
  inv := (e.symm : X₂ →ₐ[R] X₁)
  hom_inv_id' := by ext; exact e.left_inv x
  inv_hom_id' := by ext; exact e.right_inv x
#align alg_equiv.to_Algebra_iso AlgEquiv.toAlgebraIso

namespace CategoryTheory.Iso

/-- Build a `alg_equiv` from an isomorphism in the category `Algebra R`. -/
@[simps]
def toAlgEquiv {X Y : AlgebraCat R} (i : X ≅ Y) : X ≃ₐ[R] Y
    where
  toFun := i.hom
  invFun := i.inv
  left_inv := by tidy
  right_inv := by tidy
  map_add' := by tidy
  map_mul' := by tidy
  commutes' := by tidy
#align category_theory.iso.to_alg_equiv CategoryTheory.Iso.toAlgEquiv

end CategoryTheory.Iso

/-- Algebra equivalences between `algebras`s are the same as (isomorphic to) isomorphisms in
`Algebra`. -/
@[simps]
def algEquivIsoAlgebraIso {X Y : Type u} [Ring X] [Ring Y] [Algebra R X] [Algebra R Y] :
    (X ≃ₐ[R] Y) ≅ AlgebraCat.of R X ≅ AlgebraCat.of R Y
    where
  hom e := e.toAlgebraIso
  inv i := i.toAlgEquiv
#align alg_equiv_iso_Algebra_iso algEquivIsoAlgebraIso

instance (X : Type u) [Ring X] [Algebra R X] : Coe (Subalgebra R X) (AlgebraCat R) :=
  ⟨fun N => AlgebraCat.of R N⟩

instance AlgebraCat.forget_reflects_isos : ReflectsIsomorphisms (forget (AlgebraCat.{u} R))
    where reflects X Y f _ := by
    skip
    let i := as_iso ((forget (AlgebraCat.{u} R)).map f)
    let e : X ≃ₐ[R] Y := { f, i.to_equiv with }
    exact ⟨(is_iso.of_iso e.to_Algebra_iso).1⟩
#align Algebra.forget_reflects_isos AlgebraCat.forget_reflects_isos


import Lean.Meta

open Lean
open Lean.Meta

def print (msg : MessageData) : MetaM Unit := do
trace[Meta.debug] msg

def showRecInfo (declName : Name) (majorPos? : Option Nat := none) : MetaM Unit := do
let info ← mkRecursorInfo declName majorPos?
print (toString info)

theorem Iff.elim {a b c} (h₁ : (a → b) → (b → a) → c) (h₂ : a ↔ b) : c :=
  h₁ h₂.1 h₂.2

set_option trace.Meta true
set_option trace.Meta.isDefEq false

#eval showRecInfo `Acc.recOn
#eval showRecInfo `Prod.casesOn
#eval showRecInfo `List.recOn
#eval showRecInfo `List.casesOn
#eval showRecInfo `List.brecOn

#eval showRecInfo `Iff.elim (some 4)


import for_mathlib.derived.K_projective
import for_mathlib.homological_complex_op
import for_mathlib.homology_iso_Ab
import for_mathlib.hom_single_iso

noncomputable theory

universes v u

open category_theory category_theory.limits category_theory.preadditive

variables {C : Type u} {ι : Type*} [category.{v} C] [abelian C] {c : complex_shape ι}

namespace bounded_homotopy_category

open hom_single_iso_setup opposite

lemma aux₁_naturality_snd_var
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ) (f : B₁ ⟶ B₂) :
  (aux₁ P B₁ i).hom ≫
  (homology_functor AddCommGroup (complex_shape.up ℤ).symm i).map
    ((nat_trans.map_homological_complex (preadditive_yoneda.map f)
    (complex_shape.up ℤ).symm).app P.val.as.op) =
  map_hom_complex_homology _ _ f _ _ ≫ (aux₁ P B₂ i).hom :=
begin
  rw [← iso.comp_inv_eq],
  ext : 2,
  dsimp only [aux₁, iso.symm_hom, iso.symm_inv, homology_iso', homology.map_iso],
  simp only [category.assoc],
  rw [homology.map_eq_desc'_lift_left, homology.π'_desc'_assoc,
    homology.map_eq_lift_desc'_left, homology.lift_ι,
    map_hom_complex_homology,
    homology.map_eq_lift_desc'_left, homology.lift_ι, homology.π'_desc'],
  dsimp only [arrow.hom_mk_left, map_hom_complex',
    nat_trans.map_homological_complex_app_f, homology_functor_map],
  let t : _ := _, show _ ≫ _ ≫ t = _,
  have ht : t = homology.ι _ _ _ ≫
    cokernel.map _ _ (homological_complex.X_prev_iso _ _).hom (𝟙 _) _,
  rotate 2, { dsimp, refl }, { rw [category.comp_id], apply homological_complex.d_to_eq },
  { ext1, erw [homology.π'_ι_assoc, homology.π'_desc', cokernel.π_desc], refl, },
  rw [ht, homology.map_eq_lift_desc'_right, homology.lift_ι_assoc], clear ht t,
  let t : _ := _, show t ≫ _ = _,
  have ht : t = kernel.map _ _ (𝟙 _) (homological_complex.X_next_iso _ _).inv _ ≫
    homology.π' _ _ _,
  rotate 2, { dsimp, apply sub_add_cancel },
  { rw [category.id_comp], symmetry, apply homological_complex.d_from_eq },
  { ext1, erw [homology.lift_ι, category.assoc, homology.π'_ι, kernel.lift_ι_assoc], refl },
  rw [ht, category.assoc, homology.π'_desc'_assoc, category.assoc, category.assoc], clear ht t,
  rw [kernel.lift_ι_assoc, cokernel.π_desc],
  simp only [category.assoc, category.id_comp], refl,
end

lemma aux₂_naturality_snd_var
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ) (f : B₁ ⟶ B₂) :
  (aux₂ P B₁ i).inv ≫ P.map_hom_complex_homology i f _ (homological_complex.d_comp_d _ _ _ _) =
  AddCommGroup.homology_map
    (homological_complex.d_comp_d _ _ _ _)
    (homological_complex.d_comp_d _ _ _ _)
    (commsq.of_eq $ ((map_hom_complex' _ f).comm _ _).symm)
    (commsq.of_eq $ ((map_hom_complex' _ f).comm _ _).symm) ≫ (aux₂ P B₂ i).inv :=
begin
  dsimp only [aux₂, map_hom_complex_homology],
  rw ← AddCommGroup.homology_iso_inv_homology_map,
  congr' 1,
  dsimp only [homology.map'],
  erw ← has_homology.homology_map_eq',
  congr',
end
.

lemma quotient_add_group.lift_mk''
  {G H : Type*} [add_group G] [add_group H] (N : add_subgroup G) [N.normal]
  {φ : G →+ H} (HN : ∀ (x : G), x ∈ N → φ x = 0) (g : G) :
  (quotient_add_group.lift N φ HN) (quotient_add_group.mk' N g) = φ g :=
quotient_add_group.lift_mk' _ _ _

lemma _root_.AddCommGroup.has_homology_ι_eq {A B C : AddCommGroup} (f : A ⟶ B) (g : B ⟶ C) (w : f ≫ g = 0) :
  (AddCommGroup.has_homology f g w).ι =
  (AddCommGroup.of_hom $ quotient_add_group.lift _ ((quotient_add_group.mk' f.range).comp g.ker.subtype)
      begin
        rintro x ⟨a, ha⟩,
        simp only [add_monoid_hom.comp_apply, quotient_add_group.coe_mk', quotient_add_group.eq_zero_iff],
        exact ⟨a, ha⟩,
      end) ≫
    (AddCommGroup.cokernel_iso_range_quotient _).inv :=
begin
  dsimp only [AddCommGroup.has_homology, AddCommGroup.of_hom],
  ext x,
  apply_fun (AddCommGroup.cokernel_iso_range_quotient f).hom,
  { simp only [add_monoid_hom.comp_apply, comp_apply, quotient_add_group.lift_mk'',
      AddCommGroup.cokernel_π_cokernel_iso_range_quotient_hom_apply,
      category_theory.iso.inv_hom_id_apply] },
  { erw [← AddCommGroup.mono_iff_injective], apply_instance },
end
.

lemma _root_.add_monoid_hom.lift_of_surjective_apply {A B C : Type*}
  [add_comm_group A] [add_comm_group B] [add_comm_group C]
  (f : A →+ B) (hf : function.surjective f) (g : {g : A →+ C // f.ker ≤ g.ker}) (a : A) :
  add_monoid_hom.lift_of_surjective f hf g (f a) = g a :=
begin
  show g _ = g _,
  erw [← sub_eq_zero, ← g.val.map_sub, ← g.val.mem_ker],
  apply g.2,
  rw [f.mem_ker, f.map_sub, sub_eq_zero],
  apply function.surj_inv_eq
end

lemma _root_.add_equiv.symm_mk_apply {A B : Type*} [add_comm_group A] [add_comm_group B]
  (f : A → B) (g : B → A) (h1) (h2) (h3) (b : B) :
  add_equiv.symm ⟨f, g, h1, h2, h3⟩ b = g b := rfl

lemma _root_.add_monoid_hom.subtype_mk_apply {A B : Type*} [add_comm_group A] [add_comm_group B]
  (p : (A →+ B) → Prop) (f : A →+ B) (hf : p f) (a : A) :
  subtype.mk f hf a = f a := rfl

lemma homological_complex_hom_single_iso_natural_aux
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ)
  (f : B₁ ⟶ B₂)
  (φ : (add_monoid_hom.ker ((hom_complex P B₁).d i (i - 1)))) :
  ((map_hom_complex' P f).f i) φ ∈ add_monoid_hom.ker ((hom_complex P B₂).d i (i - 1)) :=
begin
  cases φ with φ hφ,
  rw [add_monoid_hom.mem_ker] at hφ ⊢,
  rw [← comp_apply, (map_hom_complex' P f).comm, comp_apply],
  erw [hφ, map_zero],
end
.

attribute [simps] eq_to_iso

lemma homological_complex_hom_single_iso_natural
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ)
  (f : B₁ ⟶ B₂)
  (φ : (add_monoid_hom.ker ((hom_complex P B₁).d i (i - 1)))) :
  homotopy_category.quotient_map_hom P.val.as ((homological_complex.single C _ i).obj B₁)
    (((homological_complex.hom_single_iso P.val.as B₁ i).symm) φ) ≫
  (single C i).map f =
  homotopy_category.quotient_map_hom P.val.as ((homological_complex.single C _ i).obj B₂)
    (((homological_complex.hom_single_iso P.val.as B₂ i).symm)
      ⟨(map_hom_complex' P f).f i φ, homological_complex_hom_single_iso_natural_aux P i f φ⟩) :=
begin
  dsimp only [homotopy_category.quotient_map_hom, add_monoid_hom.mk'_apply,
    single, homotopy_category.single, functor.comp_map],
  rw [← functor.map_comp], congr' 1,
  ext n,
  dsimp only [homological_complex.comp_f, homological_complex.hom_single_iso_symm_apply_f],
  split_ifs with hin, swap, { rw zero_comp },
  subst n,
  simp only [category.assoc], refine congr_arg2 _ rfl _,
  dsimp only [map_hom_complex', nat_trans.map_homological_complex_app_f,
    preadditive_yoneda_map_app_apply],
  simp only [category.assoc], refine congr_arg2 _ rfl _,
  dsimp only [homological_complex.single],
  rw [← category_theory.eq_to_iso_hom, ← iso.eq_inv_comp],
  exact dif_pos rfl,
end

lemma hom_single_iso_naturality_snd_var_good
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ)
  (f : B₁ ⟶ B₂) :
  (hom_single_iso P B₁ i).hom ≫
  (homology_functor _ _ i).map (nat_trans.app (nat_trans.map_homological_complex
    (preadditive_yoneda.map f) _) _) =
  (preadditive_yoneda.map $ (single C i).map f).app (op P) ≫ (hom_single_iso P B₂ i).hom :=
begin
  dsimp only [hom_single_iso, iso.trans_hom, iso.symm_hom, functor.comp_map, functor.op_map,
    functor.right_op_map, quiver.hom.unop_op],
  simp only [category.assoc],
  rw aux₁_naturality_snd_var,
  simp_rw ← category.assoc, congr' 1, simp_rw category.assoc,
  rw aux₂_naturality_snd_var,
  simp_rw ← category.assoc, congr' 1,
  rw [← iso.eq_inv_comp],
  apply (AddCommGroup.has_homology _ _ _).ext_ι,
  apply (AddCommGroup.has_homology _ _ _).ext_π,
  rotate, { apply homological_complex.d_comp_d }, { apply homological_complex.d_comp_d },
  rw [AddCommGroup.homology_map, has_homology.map_ι, has_homology.π_comp_desc],
  dsimp only [map_hom_complex', nat_trans.map_homological_complex_app_f,
    add_equiv_iso_AddCommGroup_iso],
  simp only [AddCommGroup.has_homology_ι_eq, ← category.assoc],
  rw [iso.eq_comp_inv],
  dsimp only [AddCommGroup.has_homology],
  simp only [category.assoc],
  rw [← iso.inv_comp_eq],
  ext1 φ,
  simp only [category_theory.comp_apply, AddCommGroup.kernel_iso_ker_inv_comp_ι_apply,
    AddCommGroup.cokernel_π_cokernel_iso_range_quotient_hom_apply,
    AddCommGroup.of_hom, add_equiv.to_AddCommGroup_iso, add_equiv.coe_to_add_monoid_hom],
  dsimp only [aux₃, preadditive_yoneda_map_app_apply],
  dsimp only [add_equiv.surjective_congr, add_equiv.coe_mk, add_equiv.symm_mk_apply],
  rw [add_monoid_hom.lift_of_surjective_apply, add_monoid_hom.subtype_mk_apply],
  dsimp only [add_monoid_hom.comp_apply, add_equiv.coe_to_add_monoid_hom],
  erw [homological_complex_hom_single_iso_natural P i f φ],
  rw [add_monoid_hom.lift_of_surjective_apply, add_monoid_hom.subtype_mk_apply],
  dsimp only [add_monoid_hom.comp_apply, add_equiv.coe_to_add_monoid_hom],
  rw [quotient_add_group.lift_mk'', add_equiv.apply_symm_apply, add_monoid_hom.comp_apply],
  refl,
end

lemma hom_single_iso_naturality_snd_var
  (P : bounded_homotopy_category C) {B₁ B₂ : C} (i : ℤ)
  (f : B₁ ⟶ B₂) (x : P ⟶ (single C i).obj B₁) :
  ((homology_functor _ _ i).map
    ((nat_trans.map_homological_complex (preadditive_yoneda.map f) _).app P.val.as.op))
      ((hom_single_iso P B₁ i).hom x) = ((hom_single_iso P B₂ i).hom (x ≫ (single C i).map f)) :=
begin
  have := hom_single_iso_naturality_snd_var_good P i f,
  apply_fun (λ e, e x) at this,
  exact this
end

end bounded_homotopy_category


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

import category_theory.category
import category_theory.functor

import .tactics

universes u v

namespace category_theory

structure iso {C : Type u} [category.{u v} C] (X Y : C) :=
(hom : X ⟶ Y)
(inv : Y ⟶ X)
(hom_inv_id : hom ≫ inv = 𝟙 X . obviously)
(inv_hom_id : inv ≫ hom = 𝟙 Y . obviously)

restate_axiom iso.hom_inv_id
restate_axiom iso.inv_hom_id
attribute [simp,ematch] iso.hom_inv_id_lemma iso.inv_hom_id_lemma

infixr ` ≅ `:10  := iso             -- type as \cong

variables {C : Type u} [𝒞 : category.{u v} C]
include 𝒞
variables {X Y Z : C}

namespace iso

instance : has_coe (iso.{u v} X Y) (X ⟶ Y) :=
{ coe := iso.hom }

-- -- These lemmas are quite common, to help us avoid having to muck around with associativity.
-- -- If anyone has a suggestion for automating them away, I would be very appreciative.
-- @[simp,ematch] lemma hom_inv_id_assoc_lemma (I : X ≅ Y) (f : X ⟶ Z) : I.hom ≫ I.inv ≫ f = f :=
-- begin
--   -- `obviously'` says:
--   rw [←category.assoc_lemma, iso.hom_inv_id_lemma, category.id_comp_lemma]
-- end

-- @[simp,ematch] lemma inv_hom_id_assoc_lemma (I : X ≅ Y) (f : Y ⟶ Z) : I.inv ≫ I.hom ≫ f = f :=
-- begin
--   -- `obviously'` says:
--   rw [←category.assoc_lemma, iso.inv_hom_id_lemma, category.id_comp_lemma]
-- end

@[extensionality] lemma ext
  (α β : X ≅ Y)
  (w : α.hom = β.hom) : α = β :=
  begin
    induction α with f g wα1 wα2,
    induction β with h k wβ1 wβ2,
    simp at w,
    have p : g = k,
      begin
        induction w,
        dsimp at *,
        rw [← category.id_comp_lemma C k, ←wα2, category.assoc_lemma, wβ1, category.comp_id_lemma]
      end,
    -- `obviously'` says:
    induction p, induction w,
    refl
  end

@[refl] def refl (X : C) : X ≅ X :=
{ hom := 𝟙 X,
  inv := 𝟙 X,
  hom_inv_id := begin /- `obviously'` says: -/ simp end,
  inv_hom_id := begin /- `obviously'` says: -/ simp end }

-- TODO maybe these can have ematch?
@[simp] lemma refl_map (X : C) : (iso.refl X).hom = 𝟙 X := rfl
@[simp] lemma refl_inv  (X : C) : (iso.refl X).inv  = 𝟙 X := rfl

@[trans] def trans (α : X ≅ Y) (β : Y ≅ Z) : X ≅ Z :=
{ hom := α.hom ≫ β.hom,
  inv := β.inv ≫ α.inv,
  hom_inv_id := begin /- `obviously'` says: -/ erw [category.assoc_lemma], conv { to_lhs, congr, skip, rw ← category.assoc_lemma }, rw iso.hom_inv_id_lemma, rw category.id_comp_lemma, rw iso.hom_inv_id_lemma end,
  inv_hom_id := begin /- `obviously'` says: -/ erw [category.assoc_lemma], conv { to_lhs, congr, skip, rw ← category.assoc_lemma }, rw iso.inv_hom_id_lemma, rw category.id_comp_lemma, rw iso.inv_hom_id_lemma end }

infixr ` ♢ `:80 := iso.trans -- type as \diamonds

@[simp,ematch] lemma trans_hom (α : X ≅ Y) (β : Y ≅ Z) : (α ♢ β).hom = α.hom ≫ β.hom := rfl
@[simp,ematch] lemma trans_inv (α : X ≅ Y) (β : Y ≅ Z) : (α ♢ β).inv  = β.inv ≫ α.inv   := rfl

@[symm] def symm (I : X ≅ Y) : Y ≅ X :=
{ hom := I.inv,
  inv := I.hom,
  hom_inv_id := begin /- `obviously'` says: -/ simp end,
  inv_hom_id := begin /- `obviously'` says: -/ simp end }

end iso

class is_iso (f : X ⟶ Y) :=
(inv : Y ⟶ X)
(hom_inv_id : f ≫ inv = 𝟙 X . obviously)
(inv_hom_id : inv ≫ f = 𝟙 Y . obviously)

restate_axiom is_iso.hom_inv_id
restate_axiom is_iso.inv_hom_id
attribute [simp,ematch] is_iso.hom_inv_id_lemma is_iso.inv_hom_id_lemma

namespace is_iso

instance (X : C) : is_iso (𝟙 X) :=
{ inv := 𝟙 X,
  hom_inv_id := by obviously',
  inv_hom_id := by obviously' }

instance of_iso         (f : X ≅ Y) : is_iso f.hom :=
{ inv   := f.inv,
  hom_inv_id := begin /- `obviously'` says: -/ simp end,
  inv_hom_id := begin /- `obviously'` says: -/ simp end }
instance of_iso_inverse (f : X ≅ Y) : is_iso f.inv  :=
{ inv   := f.hom,
  hom_inv_id := begin /- `obviously'` says: -/ simp end,
  inv_hom_id := begin /- `obviously'` says: -/ simp end }

end is_iso

class epi  (f : X ⟶ Y) :=
(left_cancellation : Π {Z : C} (g h : Y ⟶ Z) (w : f ≫ g = f ≫ h), g = h)
class mono (f : X ⟶ Y) :=
(right_cancellation : Π {Z : C} (g h : Z ⟶ X) (w : g ≫ f = h ≫ f), g = h)

instance epi_of_iso  (f : X ⟶ Y) [is_iso f] : epi f  :=
{ left_cancellation := begin
                         -- This is an interesting test case for better rewrite automation.
                         intros,
                         rw [←category.id_comp_lemma C g, ←category.id_comp_lemma C h],
                         rw [← is_iso.inv_hom_id_lemma f],
                         erw [category.assoc_lemma, w, category.assoc_lemma],
                       end }
instance mono_of_iso (f : X ⟶ Y) [is_iso f] : mono f :=
{ right_cancellation := begin
                         intros,
                         rw [←category.comp_id_lemma C g, ←category.comp_id_lemma C h],
                         rw [← is_iso.hom_inv_id_lemma f],
                         erw [←category.assoc_lemma, w, ←category.assoc_lemma]
                       end }

@[simp] lemma cancel_epi  (f : X ⟶ Y) [epi f]  (g h : Y ⟶ Z) : (f ≫ g = f ≫ h) ↔ g = h :=
⟨ λ p, epi.left_cancellation g h p, begin /- `obviously'` says: -/ intros, cases a, refl end ⟩
@[simp] lemma cancel_mono (f : X ⟶ Y) [mono f] (g h : Z ⟶ X) : (g ≫ f = h ≫ f) ↔ g = h :=
⟨ λ p, mono.right_cancellation g h p, begin /- `obviously'` says: -/ intros, cases a, refl end ⟩

namespace functor

universes u₁ v₁ u₂ v₂
variables {D : Type u₂}

variables [𝒟 : category.{u₂ v₂} D]
include 𝒟

def on_isos (F : C ↝ D) {X Y : C} (i : X ≅ Y) : (F X) ≅ (F Y) :=
{ hom := F.map i.hom,
  inv := F.map i.inv,
  hom_inv_id := by obviously',
  inv_hom_id := by obviously' }

@[simp,ematch] lemma on_isos_hom (F : C ↝ D) {X Y : C} (i : X ≅ Y) : (F.on_isos i).hom = F.map i.hom := rfl
@[simp,ematch] lemma on_isos_inv (F : C ↝ D) {X Y : C} (i : X ≅ Y) : (F.on_isos i).inv = F.map i.inv := rfl

end functor

end category_theory


import polytime

def time_bound_promise (c : code) (promise : set ptree) (b : ℕ → ℕ) : Prop :=
∀ x ∈ promise, ∃ t ∈ c.time x, t ≤ b x.sizeof

@[simp] lemma time_bound_promise_univ (c : code) (b : ℕ → ℕ) :
  time_bound_promise c set.univ b ↔ time_bound c b :=
by simp [time_bound, time_bound_promise]

lemma pfun.preimage_def' {α β} {f : α →. β} {S : set β} {x₁} (hx₁ : x₁ ∈ f.preimage S) {x₂} (hx₂ : x₂ ∈ f x₁) :
  x₂ ∈ S :=
by { rcases hx₁ with ⟨x₂, H, hx₂'⟩, cases part.mem_unique hx₂ hx₂', exact H, }

lemma time_bound_promise_comp {c₁ c₂ : code} {P₁ P₂ : set ptree} {b₁ b₂ : ℕ → ℕ} (hm : monotone b₁)
  (hb₁ : time_bound_promise c₁ P₁ b₁) (hb₂ : time_bound_promise c₂ P₂ b₂) :
  time_bound_promise (c₁.comp c₂) (P₂ ∩ c₂.eval.preimage P₁) (λ t, b₁ (b₂ t) + b₂ t + 1) :=
begin
  rintros v ⟨hv₁, hv₂⟩,
  obtain ⟨t₂, ht₂, hb₂⟩ := hb₂ v hv₁,
  obtain ⟨v', hv'⟩ := (_ : ∃ v', v' ∈ c₂.eval v), swap,
  { rw [← part.dom_iff_mem, ← time_dom_iff_eval_dom, part.dom_iff_mem], use [t₂, ht₂], },
  obtain ⟨t₁, ht₁, hb₁⟩ := hb₁ v' (pfun.preimage_def' hv₂ hv'),
  use t₁ + t₂ + 1, split,
  { rw ← part.eq_some_iff at ht₁ ht₂ hv', simp [code.time, ht₁, ht₂, hv', add_def], ring, },
  { mono*, exact hb₁.trans (hm ((eval_sizeof_le_time hv' ht₂).trans hb₂)), },
end

def polytime_promise (c : code) (promise : set ptree) : Prop :=
∃ p : polynomial ℕ, time_bound_promise c promise (λ n, p.eval n)

lemma polytime_promise_comp {c₁ c₂ : code} {P₁ P₂ : set ptree} :
  polytime_promise c₁ P₁ → polytime_promise c₂ P₂ → polytime_promise (c₁.comp c₂) (P₂ ∩ c₂.eval.preimage P₁)
| ⟨p₁, e₁⟩ ⟨p₂, e₂⟩ := by { use (p₁.comp p₂) + p₂ + 1, convert time_bound_promise_comp (monotone_polynomial_nat _) e₁ e₂, simp, }

@[simp] lemma polytime_promise.univ {c : code} :
  polytime_promise c set.univ ↔ polytime c :=
by simp [polytime_promise, polytime]

lemma pfun.mem_ran_iff {α β} {f : α →. β} {x} :
  x ∈ f.ran ↔ ∃ y, x ∈ f y := by refl

@[simp] lemma pfun.preimage_ran {α β} (f : α →. β) :
  f.preimage f.ran = f.dom :=
by { ext, simp [pfun.mem_ran_iff], tauto, }


import Std.Tactic.Basic

private def nonDecid (P : Prop) (x : P) : P := by
  by_contra h
  guard_hyp h : ¬P
  guard_target = False
  exact h x

private def decid (P : Prop) [Decidable P] (x : P) : P := by
  by_contra h
  guard_hyp h : ¬P
  guard_target = False
  exact h x

example (P : Prop) [Decidable P] : nonDecid P = decid P := by
  delta nonDecid nonDecid.proof_1 decid decid.proof_1
  guard_target =
    (fun x : P => Classical.byContradiction fun h => h x) =
    (fun x : P => Decidable.byContradiction fun h => h x)
  rfl

example (P : Prop) : P → P := by
  by_contra
  guard_hyp ‹_› : ¬(P → P)
  exact ‹¬(P → P)› id


import algebra.module

lemma linear_map.to_fun_eq_coe_fn {α β γ : Type*} [ring α] [add_comm_group β] [add_comm_group γ] [module α β] [module α γ]
  (f : β →ₗ[α] γ): linear_map.to_fun f = ⇑f := rfl


import Lean

@[simp] theorem ex1 (x : Nat) : 2 * x = x + x :=
  sorry

@[simp] theorem ex2 (xs : List α) : xs ++ [] = xs :=
  sorry

@[simp] theorem ex3 (xs ys zs : List α) : (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
  sorry

@[simp] theorem ex5 (p : Prop) : p ∨ True :=
  sorry

@[simp] theorem ex4 (xs : List α) : ¬(x :: xs = []) :=
  sorry

@[simp] theorem ex6 (p q : Prop) : p ∨ q ↔ q ∨ p:=
  sorry

@[simp high] theorem ex7 [Add α] (a b : α) : a + b = b + a :=
  sorry

@[simp↓] theorem ex8 [Add α] (p q : Prop) : (¬ (p ∧ q)) = (¬p ∨ ¬q) :=
  sorry

axiom aux {α} (f : List α → List α) (xs ys : List α) : f (xs ++ ys) ++ [] = f (xs ++ ys)

open Lean
open Lean.Meta

def tst1 : MetaM Unit := do
  let thms  ← Meta.getSimpTheorems
  trace[Meta.debug] "{thms.pre}\n-----\n{thms.post}"

set_option trace.Meta.debug true in
#eval tst1

def tst2 : MetaM Unit := do
  let c ← getConstInfo `aux
  forallTelescopeReducing c.type fun xs type => do
    match type.eq? with
    | none => throwError "unexpected"
    | some (_, lhs, _) =>
      trace[Meta.debug] "lhs: {lhs}"
      let s ← Meta.getSimpTheorems
      let m ← s.post.getMatch lhs
      trace[Meta.debug] "result: {m}"
      assert! m.any fun s => s.origin == .decl `ex2

set_option trace.Meta.debug true in
#eval tst2