/-
Copyright (c) 2018 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import algebra.group.defs
import data.equiv.basic
import logic.nontrivial

/-!
# Multiplicative opposite and algebraic operations on it

In this file we define `mul_opposite α = αᵐᵒᵖ` to be the multiplicative opposite of `α`. It
inherits all additive algebraic structures on `α` (in other files), and reverses the order of
multipliers in multiplicative structures, i.e., `op (x * y) = op x * op y`, where `mul_opposite.op`
is the canonical map from `α` to `αᵐᵒᵖ`.

## Notation

`αᵐᵒᵖ = mul_opposite α`
-/

universes u v
open function

/-- Multiplicative opposite of a type. This type inherits all additive structures on `α` and
reverses left and right in multiplication.-/
def mul_opposite (α : Type u) : Type u := α

postfix `ᵐᵒᵖ`:std.prec.max_plus := mul_opposite

namespace mul_opposite

variables {α : Type u}

/-- The element of `mul_opposite α` that represents `x : α`. -/
@[pp_nodot]
def op : α → αᵐᵒᵖ := id

/-- The element of `α` represented by `x : αᵐᵒᵖ`. -/
@[pp_nodot]
def unop : αᵐᵒᵖ → α := id

@[simp] lemma unop_op (x : α) : unop (op x) = x := rfl
@[simp] lemma op_unop (x : αᵐᵒᵖ) : op (unop x) = x := rfl
@[simp] lemma op_comp_unop : (op : α → αᵐᵒᵖ) ∘ unop = id := rfl
@[simp] lemma unop_comp_op : (unop : αᵐᵒᵖ → α) ∘ op = id := rfl

attribute [irreducible] mul_opposite

/-- A recursor for `opposite`. Use as `induction x using mul_opposite.rec`. -/
@[simp]
protected def rec {F : Π (X : αᵐᵒᵖ), Sort v} (h : Π X, F (op X)) : Π X, F X :=
λ X, h (unop X)

/-- The canonical bijection between `αᵐᵒᵖ` and `α`. -/
@[simps apply symm_apply { fully_applied := ff }]
def op_equiv : α ≃ αᵐᵒᵖ := ⟨op, unop, unop_op, op_unop⟩

lemma op_bijective : bijective (op : α → αᵐᵒᵖ) := op_equiv.bijective
lemma unop_bijective : bijective (unop : αᵐᵒᵖ → α) := op_equiv.symm.bijective
lemma op_injective : injective (op : α → αᵐᵒᵖ) := op_bijective.injective
lemma op_surjective : surjective (op : α → αᵐᵒᵖ) := op_bijective.surjective
lemma unop_injective : injective (unop : αᵐᵒᵖ → α) := unop_bijective.injective
lemma unop_surjective : surjective (unop : αᵐᵒᵖ → α) := unop_bijective.surjective

@[simp] lemma op_inj {x y : α} : op x = op y ↔ x = y := op_injective.eq_iff
@[simp] lemma unop_inj {x y : αᵐᵒᵖ} : unop x = unop y ↔ x = y := unop_injective.eq_iff

variable (α)

instance [nontrivial α] : nontrivial αᵐᵒᵖ := op_injective.nontrivial
instance [inhabited α] : inhabited αᵐᵒᵖ := ⟨op (default α)⟩
instance [subsingleton α] : subsingleton αᵐᵒᵖ := unop_injective.subsingleton
instance [unique α] : unique αᵐᵒᵖ := unique.mk' _
instance [is_empty α] : is_empty αᵐᵒᵖ := function.is_empty unop

instance [has_zero α] : has_zero αᵐᵒᵖ := { zero := op 0 }

instance [has_one α] : has_one αᵐᵒᵖ := { one := op 1 }

instance [has_add α] : has_add αᵐᵒᵖ :=
{ add := λ x y, op (unop x + unop y) }

instance [has_sub α] : has_sub αᵐᵒᵖ :=
{ sub := λ x y, op (unop x - unop y) }

instance [has_neg α] : has_neg αᵐᵒᵖ :=
{ neg := λ x, op $ -(unop x) }

instance [has_mul α] : has_mul αᵐᵒᵖ :=
{ mul := λ x y, op (unop y * unop x) }

instance [has_inv α] : has_inv αᵐᵒᵖ :=
{ inv := λ x, op $ (unop x)⁻¹ }

instance (R : Type*) [has_scalar R α] : has_scalar R αᵐᵒᵖ :=
{ smul := λ c x, op (c • unop x) }

section
variables (α)

@[simp] lemma op_zero [has_zero α] : op (0 : α) = 0 := rfl
@[simp]

@[simp] lemma op_one [has_one α] : op (1 : α) = 1 := rfl
@[simp] lemma unop_one [has_one α] : unop (1 : αᵐᵒᵖ) = 1 := rfl

variable {α}

@[simp] lemma op_add [has_add α] (x y : α) : op (x + y) = op x + op y := rfl
@[simp] lemma unop_add [has_add α] (x y : αᵐᵒᵖ) : unop (x + y) = unop x + unop y := rfl

@[simp] lemma op_neg [has_neg α] (x : α) : op (-x) = -op x := rfl
@[simp] lemma unop_neg [has_neg α] (x : αᵐᵒᵖ) : unop (-x) = -unop x := rfl

@[simp] lemma op_mul [has_mul α] (x y : α) : op (x * y) = op y * op x := rfl
@[simp] lemma unop_mul [has_mul α] (x y : αᵐᵒᵖ) : unop (x * y) = unop y * unop x := rfl

@[simp] lemma op_inv [has_inv α] (x : α) : op (x⁻¹) = (op x)⁻¹ := rfl
@[simp] lemma unop_inv [has_inv α] (x : αᵐᵒᵖ) : unop (x⁻¹) = (unop x)⁻¹ := rfl

@[simp] lemma op_sub [has_sub α] (x y : α) : op (x - y) = op x - op y := rfl
@[simp] lemma unop_sub [has_sub α] (x y : αᵐᵒᵖ) : unop (x - y) = unop x - unop y := rfl

@[simp] lemma op_smul {R : Type*} [has_scalar R α] (c : R) (a : α) : op (c • a) = c • op a := rfl
@[simp] lemma unop_smul {R : Type*} [has_scalar R α] (c : R) (a : αᵐᵒᵖ) :
  unop (c • a) = c • unop a := rfl

end

@[simp] lemma unop_eq_zero_iff {α} [has_zero α] (a : αᵐᵒᵖ) : a.unop = (0 : α) ↔ a = (0 : αᵐᵒᵖ) :=
unop_injective.eq_iff' rfl

@[simp] lemma op_eq_zero_iff {α} [has_zero α] (a : α) : op a = (0 : αᵐᵒᵖ) ↔ a = (0 : α) :=
op_injective.eq_iff' rfl

lemma unop_ne_zero_iff {α} [has_zero α] (a : αᵐᵒᵖ) : a.unop ≠ (0 : α) ↔ a ≠ (0 : αᵐᵒᵖ) :=
not_congr $ unop_eq_zero_iff a

lemma op_ne_zero_iff {α} [has_zero α] (a : α) : op a ≠ (0 : αᵐᵒᵖ) ↔ a ≠ (0 : α) :=
not_congr $ op_eq_zero_iff a

@[simp] lemma unop_eq_one_iff {α} [has_one α] (a : αᵐᵒᵖ) : a.unop = 1 ↔ a = 1 :=
unop_injective.eq_iff' rfl

@[simp] lemma op_eq_one_iff {α} [has_one α] (a : α) : op a = 1 ↔ a = 1 :=
op_injective.eq_iff' rfl

end mul_opposite


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison, Johannes Hölzl, Reid Barton
Ported by: Scott Morrison

! This file was ported from Lean 3 source module category_theory.category.basic
! leanprover-community/mathlib commit 8350c34a64b9bc3fc64335df8006bffcadc7baa6
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.CategoryTheory.Category.Init
import Mathlib.Combinatorics.Quiver.Basic
import Mathlib.Tactic.RestateAxiom
import Mathlib.Tactic.Convert
import Mathlib.Tactic.Replace

/-!
# Categories

Defines a category, as a type class parametrised by the type of objects.

## Notations

Introduces notations
* `X ⟶ Y` for the morphism spaces (type as `\hom`),
* `𝟙 X` for the identity morphism on `X` (type as `\b1`),
* `f ≫ g` for composition in the 'arrows' convention (type as `\gg`).

Users may like to add `f ⊚ g` for composition in the standard convention, using
```lean
local notation f ` ⊚ `:80 g:80 := category.comp g f    -- type as \oo
```

## Porting note
I am experimenting with using the `aesop` tactic as a replacement for `tidy`.
-/

library_note "CategoryTheory universes"
/--
The typeclass `Category C` describes morphisms associated to objects of type `C : Type u`.

The universe levels of the objects and morphisms are independent, and will often need to be
specified explicitly, as `Category.{v} C`.

Typically any concrete example will either be a `SmallCategory`, where `v = u`,
which can be introduced as
```
universes u
variables {C : Type u} [SmallCategory C]
```
or a `LargeCategory`, where `u = v+1`, which can be introduced as
```
universes u
variables {C : Type (u+1)} [LargeCategory C]
```

In order for the library to handle these cases uniformly,
we generally work with the unconstrained `Category.{v u}`,
for which objects live in `Type u` and morphisms live in `Type v`.

Because the universe parameter `u` for the objects can be inferred from `C`
when we write `Category C`, while the universe parameter `v` for the morphisms
can not be automatically inferred, through the category theory library
we introduce universe parameters with morphism levels listed first,
as in
```
universes v u
```
or
```
universes v₁ v₂ u₁ u₂
```
when multiple independent universes are needed.

This has the effect that we can simply write `Category.{v} C`
(that is, only specifying a single parameter) while `u` will be inferred.

Often, however, it's not even necessary to include the `.{v}`.
(Although it was in earlier versions of Lean.)
If it is omitted a "free" universe will be used.
-/

namespace Std.Tactic.Ext
open Lean Elab Tactic

/-- A wrapper for `ext` that will fail if it does not make progress. -/
-- After https://github.com/leanprover/std4/pull/33
-- we can just `` evalTactic (← `(tactic| ext))``
-- (But it would be good to have a name for that, too, so we can pass it to aesop.)
def extCore' : TacticM Unit := do
  let gs ← Std.Tactic.Ext.extCore (← getMainGoal) [] 1000000 true
  replaceMainGoal <| gs.map (·.1) |>.toList

end Std.Tactic.Ext

universe v u

namespace CategoryTheory

/-- A preliminary structure on the way to defining a category,
containing the data, but none of the axioms. -/
class CategoryStruct (obj : Type u) extends Quiver.{v + 1} obj : Type max u (v + 1) where
  /-- The identity morphism on an object. -/
  id : ∀ X : obj, Hom X X
  /-- Composition of morphisms in a category, written `f ≫ g`. -/
  comp : ∀ {X Y Z : obj}, (X ⟶ Y) → (Y ⟶ Z) → (X ⟶ Z)
#align category_theory.category_struct CategoryTheory.CategoryStruct

/-- Notation for the identity morphism in a category. -/
notation "𝟙" => CategoryStruct.id  -- type as \b1

/-- Notation for composition of morphisms in a category. -/
infixr:80 " ≫ " => CategoryStruct.comp -- type as \gg

/--
A thin wrapper for `aesop` which adds the `CategoryTheory` rule set and
allows `aesop` to look through semireducible definitions when calling `intros`.
This tactic fails when it is unable to solve the goal, making it suitable for
use in auto-params.
-/
macro (name := aesop_cat) "aesop_cat" c:Aesop.tactic_clause*: tactic =>
`(tactic|
  aesop $c* (options := { introsTransparency? := some .default, terminal := true })
  (rule_sets [$(Lean.mkIdent `CategoryTheory):ident]))

/--
A variant of `aesop_cat` which does not fail when it is unable to solve the
goal. Use this only for exploration! Nonterminal `aesop` is even worse than
nonterminal `simp`.
-/
macro (name := aesop_cat_nonterminal) "aesop_cat_nonterminal" c:Aesop.tactic_clause*: tactic =>
  `(tactic|
    aesop $c* (options := { introsTransparency? := some .default, warnOnNonterminal := false })
    (rule_sets [$(Lean.mkIdent `CategoryTheory):ident]))

-- We turn on `ext` inside `aesop_cat`.
attribute [aesop safe tactic (rule_sets [CategoryTheory])] Std.Tactic.Ext.extCore'

/-- The typeclass `Category C` describes morphisms associated to objects of type `C`.
The universe levels of the objects and morphisms are unconstrained, and will often need to be
specified explicitly, as `Category.{v} C`. (See also `LargeCategory` and `SmallCategory`.)

See <https://stacks.math.columbia.edu/tag/0014>.
-/
class Category (obj : Type u) extends CategoryStruct.{v} obj : Type max u (v + 1) where
  /-- Identity morphisms are left identities for composition. -/
  id_comp : ∀ {X Y : obj} (f : X ⟶ Y), 𝟙 X ≫ f = f := by aesop_cat
  /-- Identity morphisms are right identities for composition. -/
  comp_id : ∀ {X Y : obj} (f : X ⟶ Y), f ≫ 𝟙 Y = f := by aesop_cat
  /-- Composition in a category is associative. -/
  assoc : ∀ {W X Y Z : obj} (f : W ⟶ X) (g : X ⟶ Y) (h : Y ⟶ Z), (f ≫ g) ≫ h = f ≫ g ≫ h :=
    by aesop_cat
#align category_theory.category CategoryTheory.Category
#align category_theory.category.assoc CategoryTheory.Category.assoc
#align category_theory.category.comp_id CategoryTheory.Category.comp_id
#align category_theory.category.id_comp CategoryTheory.Category.id_comp

-- Porting note: `restate_axiom` should not be necessary in lean4
-- Hopefully we can just remove the backticks from field names,
-- then delete the invocation of `restate_axiom`.

attribute [simp] Category.id_comp Category.comp_id Category.assoc
attribute [trans] CategoryStruct.comp

example {C} [Category C] {X Y : C} (f : X ⟶ Y) : 𝟙 X ≫ f = f := by simp
example {C} [Category C] {X Y : C} (f : X ⟶ Y) : f ≫ 𝟙 Y = f := by simp

/-- A `LargeCategory` has objects in one universe level higher than the universe level of
the morphisms. It is useful for examples such as the category of types, or the category
of groups, etc.
-/
abbrev LargeCategory (C : Type (u + 1)) : Type (u + 1) := Category.{u} C
#align category_theory.large_category CategoryTheory.LargeCategory

/-- A `SmallCategory` has objects and morphisms in the same universe level.
-/
abbrev SmallCategory (C : Type u) : Type (u + 1) := Category.{u} C
#align category_theory.small_category CategoryTheory.SmallCategory

section

variable {C : Type u} [Category.{v} C] {X Y Z : C}

initialize_simps_projections Category

/-- postcompose an equation between morphisms by another morphism -/

/-- precompose an equation between morphisms by another morphism -/
theorem whisker_eq (f : X ⟶ Y) {g h : Y ⟶ Z} (w : g = h) : f ≫ g = f ≫ h := by rw [w]
#align category_theory.whisker_eq CategoryTheory.whisker_eq

/--
Notation for whiskering an equation by a morphism (on the right).
If `f g : X ⟶ Y` and `w : f = g` and `h : Y ⟶ Z`, then `w =≫ h : f ≫ h = g ≫ h`.
-/
infixr:80 " =≫ " => eq_whisker

/--
Notation for whiskering an equation by a morphism (on the left).
If `g h : Y ⟶ Z` and `w : g = h` and `h : X ⟶ Y`, then `f ≫= w : f ≫ g = f ≫ h`.
-/
infixr:80 " ≫= " => whisker_eq

theorem eq_of_comp_left_eq {f g : X ⟶ Y} (w : ∀ {Z : C} (h : Y ⟶ Z), f ≫ h = g ≫ h) :
    f = g := by
  convert w (𝟙 Y) <;>
  aesop
#align category_theory.eq_of_comp_left_eq CategoryTheory.eq_of_comp_left_eq

theorem eq_of_comp_right_eq {f g : Y ⟶ Z} (w : ∀ {X : C} (h : X ⟶ Y), h ≫ f = h ≫ g) :
    f = g := by
  convert w (𝟙 Y) <;>
  aesop
#align category_theory.eq_of_comp_right_eq CategoryTheory.eq_of_comp_right_eq

theorem eq_of_comp_left_eq' (f g : X ⟶ Y)
    (w : (fun {Z} (h : Y ⟶ Z) => f ≫ h) = fun {Z} (h : Y ⟶ Z) => g ≫ h) : f = g :=
  eq_of_comp_left_eq @fun Z h => by convert congr_fun (congr_fun w Z) h
#align category_theory.eq_of_comp_left_eq' CategoryTheory.eq_of_comp_left_eq'

theorem eq_of_comp_right_eq' (f g : Y ⟶ Z)
    (w : (fun {X} (h : X ⟶ Y) => h ≫ f) = fun {X} (h : X ⟶ Y) => h ≫ g) : f = g :=
  eq_of_comp_right_eq @fun X h => by convert congr_fun (congr_fun w X) h
#align category_theory.eq_of_comp_right_eq' CategoryTheory.eq_of_comp_right_eq'

theorem id_of_comp_left_id (f : X ⟶ X) (w : ∀ {Y : C} (g : X ⟶ Y), f ≫ g = g) : f = 𝟙 X := by
  convert w (𝟙 X)
  aesop
#align category_theory.id_of_comp_left_id CategoryTheory.id_of_comp_left_id

theorem id_of_comp_right_id (f : X ⟶ X) (w : ∀ {Y : C} (g : Y ⟶ X), g ≫ f = g) : f = 𝟙 X := by
  convert w (𝟙 X)
  aesop
#align category_theory.id_of_comp_right_id CategoryTheory.id_of_comp_right_id

theorem comp_ite {P : Prop} [Decidable P] {X Y Z : C} (f : X ⟶ Y) (g g' : Y ⟶ Z) :
    (f ≫ if P then g else g') = if P then f ≫ g else f ≫ g' := by aesop
#align category_theory.comp_ite CategoryTheory.comp_ite

theorem ite_comp {P : Prop} [Decidable P] {X Y Z : C} (f f' : X ⟶ Y) (g : Y ⟶ Z) :
    (if P then f else f') ≫ g = if P then f ≫ g else f' ≫ g := by aesop
#align category_theory.ite_comp CategoryTheory.ite_comp

theorem comp_dite {P : Prop} [Decidable P]
    {X Y Z : C} (f : X ⟶ Y) (g : P → (Y ⟶ Z)) (g' : ¬P → (Y ⟶ Z)) :
    (f ≫ if h : P then g h else g' h) = if h : P then f ≫ g h else f ≫ g' h := by aesop
#align category_theory.comp_dite CategoryTheory.comp_dite

theorem dite_comp {P : Prop} [Decidable P]
    {X Y Z : C} (f : P → (X ⟶ Y)) (f' : ¬P → (X ⟶ Y)) (g : Y ⟶ Z) :
    (if h : P then f h else f' h) ≫ g = if h : P then f h ≫ g else f' h ≫ g := by aesop
#align category_theory.dite_comp CategoryTheory.dite_comp

/-- A morphism `f` is an epimorphism if it can be cancelled when precomposed:
`f ≫ g = f ≫ h` implies `g = h`.

See <https://stacks.math.columbia.edu/tag/003B>.
-/
class Epi (f : X ⟶ Y) : Prop where
  /-- A morphism `f` is an epimorphism if it can be cancelled when precomposed. -/
  left_cancellation : ∀ {Z : C} (g h : Y ⟶ Z), f ≫ g = f ≫ h → g = h
#align category_theory.epi CategoryTheory.Epi

/-- A morphism `f` is a monomorphism if it can be cancelled when postcomposed:
`g ≫ f = h ≫ f` implies `g = h`.

See <https://stacks.math.columbia.edu/tag/003B>.
-/
class Mono (f : X ⟶ Y) : Prop where
  /-- A morphism `f` is an monomorphism if it can be cancelled when postcomposed. -/
  right_cancellation : ∀ {Z : C} (g h : Z ⟶ X), g ≫ f = h ≫ f → g = h
#align category_theory.mono CategoryTheory.Mono

instance (X : C) : Epi (𝟙 X) :=
  ⟨fun g h w => by aesop⟩

instance (X : C) : Mono (𝟙 X) :=
  ⟨fun g h w => by aesop⟩

theorem cancel_epi (f : X ⟶ Y) [Epi f] {g h : Y ⟶ Z} : f ≫ g = f ≫ h ↔ g = h :=
  ⟨fun p => Epi.left_cancellation g h p, congr_arg _⟩
#align category_theory.cancel_epi CategoryTheory.cancel_epi

theorem cancel_mono (f : X ⟶ Y) [Mono f] {g h : Z ⟶ X} : g ≫ f = h ≫ f ↔ g = h :=
  -- Porting note: in Lean 3 we could just write `congr_arg _` here.
  ⟨fun p => Mono.right_cancellation g h p, congr_arg (fun k => k ≫ f)⟩
#align category_theory.cancel_mono CategoryTheory.cancel_mono

theorem cancel_epi_id (f : X ⟶ Y) [Epi f] {h : Y ⟶ Y} : f ≫ h = f ↔ h = 𝟙 Y := by
  -- Porting note: `convert` became less powerful!
  -- It used to suffice to write `cancel_epi f` here.
  convert @cancel_epi _ _ _ _ _ f _ h (𝟙 Y)
  simp
#align category_theory.cancel_epi_id CategoryTheory.cancel_epi_id

theorem cancel_mono_id (f : X ⟶ Y) [Mono f] {g : X ⟶ X} : g ≫ f = f ↔ g = 𝟙 X := by
  -- Porting note: `convert` became less powerful!
  -- It used to suffice to write `cancel_mono f` here.
  convert @cancel_mono _ _ _ _ _ f _ g (𝟙 X)
  simp
#align category_theory.cancel_mono_id CategoryTheory.cancel_mono_id

theorem epi_comp {X Y Z : C} (f : X ⟶ Y) [Epi f] (g : Y ⟶ Z) [Epi g] : Epi (f ≫ g) := by
  constructor
  intro Z a b w
  apply (cancel_epi g).1
  apply (cancel_epi f).1
  simpa using w
#align category_theory.epi_comp CategoryTheory.epi_comp

theorem mono_comp {X Y Z : C} (f : X ⟶ Y) [Mono f] (g : Y ⟶ Z) [Mono g] : Mono (f ≫ g) := by
  constructor
  intro Z a b w
  apply (cancel_mono f).1
  apply (cancel_mono g).1
  simpa using w
#align category_theory.mono_comp CategoryTheory.mono_comp

theorem mono_of_mono {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [Mono (f ≫ g)] : Mono f := by
  constructor
  intro Z a b w
  replace w := congr_arg (fun k => k ≫ g) w
  dsimp at w
  rw [Category.assoc, Category.assoc] at w
  exact (cancel_mono _).1 w
#align category_theory.mono_of_mono CategoryTheory.mono_of_mono

theorem mono_of_mono_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [Mono h]
    (w : f ≫ g = h) : Mono f := by
  subst h
  exact mono_of_mono f g
#align category_theory.mono_of_mono_fac CategoryTheory.mono_of_mono_fac

theorem epi_of_epi {X Y Z : C} (f : X ⟶ Y) (g : Y ⟶ Z) [Epi (f ≫ g)] : Epi g := by
  constructor
  intro Z a b w
  replace w := congr_arg (fun k => f ≫ k) w
  dsimp at w
  rw [← Category.assoc, ← Category.assoc] at w
  exact (cancel_epi _).1 w
#align category_theory.epi_of_epi CategoryTheory.epi_of_epi

theorem epi_of_epi_fac {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} {h : X ⟶ Z} [Epi h]
    (w : f ≫ g = h) : Epi g := by
  subst h; exact epi_of_epi f g
#align category_theory.epi_of_epi_fac CategoryTheory.epi_of_epi_fac

end

section

variable (C : Type u)

variable [Category.{v} C]

universe u'

instance uliftCategory : Category.{v} (ULift.{u'} C) where
  Hom X Y := X.down ⟶ Y.down
  id X := 𝟙 X.down
  comp f g := f ≫ g
#align category_theory.ulift_category CategoryTheory.uliftCategory

-- We verify that this previous instance can lift small categories to large categories.
example (D : Type u) [SmallCategory D] : LargeCategory (ULift.{u + 1} D) := by infer_instance

end

end CategoryTheory

-- Porting note: We hope that this will become less necessary,
-- as in Lean4 `simp` will automatically enter "`dsimp` mode" when needed with dependent arguments.
-- Optimistically, we will eventually remove this library note.
library_note "dsimp, simp"
/-- Many proofs in the category theory library use the `dsimp, simp` pattern,
which typically isn't necessary elsewhere.

One would usually hope that the same effect could be achieved simply with `simp`.

The essential issue is that composition of morphisms involves dependent types.
When you have a chain of morphisms being composed, say `f : X ⟶ Y` and `g : Y ⟶ Z`,
then `simp` can operate succesfully on the morphisms
(e.g. if `f` is the identity it can strip that off).

However if we have an equality of objects, say `Y = Y'`,
then `simp` can't operate because it would break the typing of the composition operations.
We rarely have interesting equalities of objects
(because that would be "evil" --- anything interesting should be expressed as an isomorphism
and tracked explicitly),
except of course that we have plenty of definitional equalities of objects.

`dsimp` can apply these safely, even inside a composition.

After `dsimp` has cleared up the object level, `simp` can resume work on the morphism level ---
but without the `dsimp` step, because `simp` looks at expressions syntactically,
the relevant lemmas might not fire.

There's no bound on how many times you potentially could have to switch back and forth,
if the `simp` introduced new objects we again need to `dsimp`.
In practice this does occur, but only rarely, because `simp` tends to shorten chains of compositions
(i.e. not introduce new objects at all).
-/


-- Derek Johnson

def s1 := "Hello, "
def s2 := "Nifty!"
def s3 := s1 ++ s2

theorem t1 : (s1 ++ s2) = s3 := eq.refl s3

theorem t2 : 4^2 = 16 := eq.refl 16

theorem t3 : (s1 ++ s2) = s3 ∧ (5^2 = 25) := and.intro
    (eq.refl s3)
    (eq.refl 25)

theorem t4 :
    ∀ (P Q R : Prop), (P ∧ Q) ∧ (Q ∧ R) → (P ∧ R) :=
    λ (P Q R : Prop),
        λ h,
            and.intro (h.left.left)(h.right.right)


/-
Copyright (c) 2018 Michael Jendrusch. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Michael Jendrusch, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monoidal.category
import Mathlib.PostPort

universes v₁ v₂ u₁ u₂ l u₃ v₃

namespace Mathlib

/-!
# (Lax) monoidal functors

A lax monoidal functor `F` between monoidal categories `C` and `D`
is a functor between the underlying categories equipped with morphisms
* `ε : 𝟙_ D ⟶ F.obj (𝟙_ C)` (called the unit morphism)
* `μ X Y : (F.obj X) ⊗ (F.obj Y) ⟶ F.obj (X ⊗ Y)` (called the tensorator, or strength).
satisfying various axioms.

A monoidal functor is a lax monoidal functor for which `ε` and `μ` are isomorphisms.

We show that the composition of (lax) monoidal functors gives a (lax) monoidal functor.

See also `category_theory.monoidal.functorial` for a typeclass decorating an object-level
function with the additional data of a monoidal functor.
This is useful when stating that a pre-existing functor is monoidal.

See `category_theory.monoidal.natural_transformation` for monoidal natural transformations.

We show in `category_theory.monoidal.Mon_` that lax monoidal functors take monoid objects
to monoid objects.

## Future work
* Oplax monoidal functors.

## References

See https://stacks.math.columbia.edu/tag/0FFL.
-/

namespace category_theory

/-- A lax monoidal functor is a functor `F : C ⥤ D` between monoidal categories, equipped with morphisms
    `ε : 𝟙 _D ⟶ F.obj (𝟙_ C)` and `μ X Y : F.obj X ⊗ F.obj Y ⟶ F.obj (X ⊗ Y)`, satisfying the
    the appropriate coherences. -/
-- unit morphism

structure lax_monoidal_functor (C : Type u₁) [category C] [monoidal_category C] (D : Type u₂) [category D] [monoidal_category D]
extends C ⥤ D
where
  ε : 𝟙_ ⟶ functor.obj _to_functor 𝟙_
  μ : (X Y : C) → functor.obj _to_functor X ⊗ functor.obj _to_functor Y ⟶ functor.obj _to_functor (X ⊗ Y)
  μ_natural' : autoParam
  (∀ {X Y X' Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y'),
    (functor.map _to_functor f ⊗ functor.map _to_functor g) ≫ μ Y Y' = μ X X' ≫ functor.map _to_functor (f ⊗ g))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  associativity' : autoParam
  (∀ (X Y Z : C),
    (μ X Y ⊗ 𝟙) ≫ μ (X ⊗ Y) Z ≫ functor.map _to_functor (iso.hom α_) = iso.hom α_ ≫ (𝟙 ⊗ μ Y Z) ≫ μ X (Y ⊗ Z))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  left_unitality' : autoParam (∀ (X : C), iso.hom λ_ = (ε ⊗ 𝟙) ≫ μ 𝟙_ X ≫ functor.map _to_functor (iso.hom λ_))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])
  right_unitality' : autoParam (∀ (X : C), iso.hom ρ_ = (𝟙 ⊗ ε) ≫ μ X 𝟙_ ≫ functor.map _to_functor (iso.hom ρ_))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
    (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

-- tensorator

-- associativity of the tensorator

-- unitality

@[simp] theorem lax_monoidal_functor.μ_natural {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) {X : C} {Y : C} {X' : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') : (functor.map (lax_monoidal_functor.to_functor c) f ⊗ functor.map (lax_monoidal_functor.to_functor c) g) ≫
    lax_monoidal_functor.μ c Y Y' =
  lax_monoidal_functor.μ c X X' ≫ functor.map (lax_monoidal_functor.to_functor c) (f ⊗ g) := sorry

@[simp] theorem lax_monoidal_functor.μ_natural_assoc {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) {X : C} {Y : C} {X' : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') : ∀ {X'_1 : D} (f' : functor.obj (lax_monoidal_functor.to_functor c) (Y ⊗ Y') ⟶ X'_1),
  (functor.map (lax_monoidal_functor.to_functor c) f ⊗ functor.map (lax_monoidal_functor.to_functor c) g) ≫
      lax_monoidal_functor.μ c Y Y' ≫ f' =
    lax_monoidal_functor.μ c X X' ≫ functor.map (lax_monoidal_functor.to_functor c) (f ⊗ g) ≫ f' := sorry

@[simp] theorem lax_monoidal_functor.left_unitality {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) (X : C) : iso.hom λ_ =
  (lax_monoidal_functor.ε c ⊗ 𝟙) ≫
    lax_monoidal_functor.μ c 𝟙_ X ≫ functor.map (lax_monoidal_functor.to_functor c) (iso.hom λ_) := sorry

@[simp] theorem lax_monoidal_functor.right_unitality {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) (X : C) : iso.hom ρ_ =
  (𝟙 ⊗ lax_monoidal_functor.ε c) ≫
    lax_monoidal_functor.μ c X 𝟙_ ≫ functor.map (lax_monoidal_functor.to_functor c) (iso.hom ρ_) := sorry

@[simp] theorem lax_monoidal_functor.associativity {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (c : lax_monoidal_functor C D) (X : C) (Y : C) (Z : C) : (lax_monoidal_functor.μ c X Y ⊗ 𝟙) ≫
    lax_monoidal_functor.μ c (X ⊗ Y) Z ≫ functor.map (lax_monoidal_functor.to_functor c) (iso.hom α_) =
  iso.hom α_ ≫ (𝟙 ⊗ lax_monoidal_functor.μ c Y Z) ≫ lax_monoidal_functor.μ c X (Y ⊗ Z) := sorry

-- When `rewrite_search` lands, add @[search] attributes to

-- lax_monoidal_functor.μ_natural lax_monoidal_functor.left_unitality

-- lax_monoidal_functor.right_unitality lax_monoidal_functor.associativity

/--
A monoidal functor is a lax monoidal functor for which the tensorator and unitor as isomorphisms.

See https://stacks.math.columbia.edu/tag/0FFL.
-/
structure monoidal_functor (C : Type u₁) [category C] [monoidal_category C] (D : Type u₂) [category D] [monoidal_category D]
extends lax_monoidal_functor C D
where
  ε_is_iso : autoParam (is_iso (lax_monoidal_functor.ε _to_lax_monoidal_functor))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])
  μ_is_iso : autoParam ((X Y : C) → is_iso (lax_monoidal_functor.μ _to_lax_monoidal_functor X Y))
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])

/--
The unit morphism of a (strong) monoidal functor as an isomorphism.
-/
def monoidal_functor.ε_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) : 𝟙_ ≅ functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F)) 𝟙_ :=
  as_iso (lax_monoidal_functor.ε (monoidal_functor.to_lax_monoidal_functor F))

/--
The tensorator of a (strong) monoidal functor as an isomorphism.
-/
def monoidal_functor.μ_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) (X : C) (Y : C) : functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F)) X ⊗
    functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F)) Y ≅
  functor.obj (lax_monoidal_functor.to_functor (monoidal_functor.to_lax_monoidal_functor F)) (X ⊗ Y) :=
  as_iso (lax_monoidal_functor.μ (monoidal_functor.to_lax_monoidal_functor F) X Y)

namespace lax_monoidal_functor

/-- The identity lax monoidal functor. -/
@[simp] theorem id_ε (C : Type u₁) [category C] [monoidal_category C] : ε (id C) = 𝟙 :=
  Eq.refl (ε (id C))

protected instance inhabited (C : Type u₁) [category C] [monoidal_category C] : Inhabited (lax_monoidal_functor C C) :=
  { default := id C }

end lax_monoidal_functor

namespace monoidal_functor

theorem map_tensor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) {X : C} {Y : C} {X' : C} {Y' : C} (f : X ⟶ Y) (g : X' ⟶ Y') : functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (f ⊗ g) =
  inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) X X') ≫
    (functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) f ⊗
        functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) g) ≫
      lax_monoidal_functor.μ (to_lax_monoidal_functor F) Y Y' := sorry

theorem map_left_unitor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) (X : C) : functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (iso.hom λ_) =
  inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) 𝟙_ X) ≫
    (inv (lax_monoidal_functor.ε (to_lax_monoidal_functor F)) ⊗ 𝟙) ≫ iso.hom λ_ := sorry

theorem map_right_unitor {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) (X : C) : functor.map (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) (iso.hom ρ_) =
  inv (lax_monoidal_functor.μ (to_lax_monoidal_functor F) X 𝟙_) ≫
    (𝟙 ⊗ inv (lax_monoidal_functor.ε (to_lax_monoidal_functor F))) ≫ iso.hom ρ_ := sorry

/-- The tensorator as a natural isomorphism. -/
def μ_nat_iso {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] (F : monoidal_functor C D) : functor.prod (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F))
      (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F)) ⋙
    monoidal_category.tensor D ≅
  monoidal_category.tensor C ⋙ lax_monoidal_functor.to_functor (to_lax_monoidal_functor F) :=
  nat_iso.of_components (fun (X : C × C) => μ_iso F (prod.fst X) (prod.snd X)) sorry

/-- The identity monoidal functor. -/
def id (C : Type u₁) [category C] [monoidal_category C] : monoidal_functor C C :=
  mk (lax_monoidal_functor.mk (functor.mk (functor.obj 𝟭) (functor.map 𝟭)) 𝟙 fun (X Y : C) => 𝟙)

protected instance inhabited (C : Type u₁) [category C] [monoidal_category C] : Inhabited (monoidal_functor C C) :=
  { default := id C }

end monoidal_functor

namespace lax_monoidal_functor

-- The proofs here are horrendous; rewrite_search helps a lot.

/-- The composition of two lax monoidal functors is again lax monoidal. -/
@[simp] theorem comp_ε {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] {E : Type u₃} [category E] [monoidal_category E] (F : lax_monoidal_functor C D) (G : lax_monoidal_functor D E) : ε (comp F G) = ε G ≫ functor.map (to_functor G) (ε F) :=
  Eq.refl (ε (comp F G))

infixr:80 " ⊗⋙ " => Mathlib.category_theory.lax_monoidal_functor.comp

end lax_monoidal_functor

namespace monoidal_functor

/-- The composition of two monoidal functors is again monoidal. -/
def comp {C : Type u₁} [category C] [monoidal_category C] {D : Type u₂} [category D] [monoidal_category D] {E : Type u₃} [category E] [monoidal_category E] (F : monoidal_functor C D) (G : monoidal_functor D E) : monoidal_functor C E :=
  mk
    (lax_monoidal_functor.mk (lax_monoidal_functor.to_functor (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G))
      (lax_monoidal_functor.ε (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G))
      (lax_monoidal_functor.μ (to_lax_monoidal_functor F ⊗⋙ to_lax_monoidal_functor G)))

infixr:80 " ⊗⋙ " => Mathlib.category_theory.monoidal_functor.comp


import prelim.embed prelim.minmax set_tactic.solver
import .minor

open_locale classical
noncomputable theory
open matroid set matroid_in

universes u v w

namespace matroid_in.minor_pair

variables {α β : Type*} [fintype α] [fintype β]
{N M : matroid_in α}

-- The next few definitions relate a minor pair N M to a minor pair N' M.as_mat

def subset_pair_equiv {X Y : set α} (h : X ⊆ Y) :=
  equiv.set.range
    (λ (x : X), (⟨x.val, mem_of_mem_of_subset x.property h⟩ : Y))
    (λ x y hxy, by {cases x, cases y, dsimp at hxy, rwa subtype.mk_eq_mk at *,  })

def subtype_equiv (P : minor_pair N M) := subset_pair_equiv P.NE_ss_ME

@[simp] lemma subset_pair_equiv_apply {X Y : set α} (h : X ⊆ Y) (x : X) :
  subset_pair_equiv h x = ⟨⟨x.val, mem_of_mem_of_subset x.property h⟩, mem_range_self x⟩ :=
rfl

@[simp] lemma subtype_equiv_apply (P : minor_pair N M) (x : N.E) :
  P.subtype_equiv x = ⟨⟨x.val, mem_of_mem_of_subset x.property P.NE_ss_ME⟩, mem_range_self x⟩  :=
rfl

/-- for a minor pair N M, gives the isomorphism from N to the corresponding minor N'
of M.as_mat. Not a fun proof because dependent types are annoying - can we improve it?-/
def minor_isom_minor_as_mat (P : minor_pair N M) :
  N.isom ((M.as_mat : matroid_in M.E) / (coe ⁻¹' P.C) \ (coe ⁻¹' P.D)) :=
⟨ P.subtype_equiv.trans (equiv.set.of_eq begin
    simp only with msimp,
    ext, cases x with x hx,
    simp only [exists_prop, set_coe.exists, mem_range, exists_eq_right,
    mem_preimage, mem_diff, subtype.coe_mk, univ_diff, mem_compl_eq],
    rw [←not_iff_not, decidable.not_and_distrib, not_not, not_not,
    ←mem_union, P.union, mem_diff], tauto, end ),
  λ X, begin
    simp only with msimp, rw P.rank_subtype,
    congr, swap, unfold_coes,
    rw [image_preimage_eq_of_subset],
    rw [subtype.range_val], exact P.C_ss_E,
    unfold_coes,
    rw [image_union, image_diff, image_preimage_eq_of_subset, image_preimage_eq_of_subset],
    rotate,
    { rw [subtype.range_val], exact P.C_ss_E},
    { rw [subtype.range_val], exact P.D_ss_E},
    { exact subtype.val_injective},
    ext, rw [mem_union, mem_diff], conv
    { to_lhs, congr, congr, rw mem_image, congr, funext, rw mem_image,
      conv {congr, congr, funext, rw mem_image, },},
     simp, split,
     rintro (⟨⟨x, hx, ⟨x',⟨hx'C,hx'D⟩,⟨⟨hxN,hxX⟩,hx'X, rfl⟩⟩, rfl⟩, hxD⟩ | hxC),
     { left, exact ⟨hxN, hxX⟩}, {right, assumption},
     rintro (⟨hxE, hxX⟩ | hxC), swap, right, assumption, left,
     have hxM := mem_of_mem_of_subset hxE P.NE_ss_ME,
     have hxC : x ∉ P.C := nonmem_of_mem_disjoint hxE P.NE_inter_C,
     have hxD : x ∉ P.D := nonmem_of_mem_disjoint hxE P.NE_inter_D,
     refine ⟨⟨x,⟨_,⟨x,⟨⟨_,_⟩,⟨⟨hxE,_⟩,⟨_,rfl⟩⟩⟩⟩,rfl⟩⟩,_⟩;
     assumption,
    end⟩

/-- the image of a cd_pair under a matroid isomorphism -/
def image_cd_pair {M : matroid α} {M' : matroid β} (p : cd_pair (M : matroid_in α))
(i : M.isom M') :
  cd_pair (M' : matroid_in β) :=
{ C := (i.equiv '' p.C),
  D := (i.equiv '' p.D),
  disj := by rw [(image_inter i.equiv.injective), p.disj, image_empty],
  C_ss_E := λ x hx, by simp,
  D_ss_E := λ x hx, by simp}

/-- given a minor pair N,M, an isomorphism from M to M' maps it to a minor pair N',M' -/
def image_minor_pair {N M : matroid_in α} {M' : matroid_in β}
(i : isom M M') (P : minor_pair N M) :
  minor_pair (M' / (i.equiv '' (coe ⁻¹' P.C)) \ (i.equiv '' (coe ⁻¹' P.D))) M' :=
{ minor := rfl, .. cd_pair.from_as_mat (image_cd_pair (cd_pair.to_as_mat (coe P)) i) }

/-- given a matroid M, a minor_pair N M, and a matroid M' isomorphic to M, gives an isomorphism
from N to the corresponding minor N' of M' -/
def minor_matroid_to_minor_iso {M : matroid α} {M' : matroid β} {N : matroid_in α}
  (P : minor_pair N M) (i : M.isom M') :
  N.isom ((M' : matroid_in β) / (i.equiv '' P.C) \ (i.equiv '' P.D)) :=
⟨ (equiv.set.image i.equiv _ i.equiv.injective).trans (equiv.set.of_eq (
  by {simp only with msimp,
      rw [diff_diff, ←image_union, P.union, univ_diff, ←equiv.image_compl, coe_E],
      simp,})) ,
  begin
    intro X, simp_rw [as_mat_r, P.rank_subtype, coe_r, ←i.on_rank],
    simp only with msimp, congr,
    simp_rw [←equiv.preimage_eq_iff_eq_image, preimage_union, preimage_diff, equiv.preimage_image],
    congr' 1, unfold_coes, ext,

    conv {congr, rw mem_diff, congr, rw mem_preimage, rw mem_image, congr, funext,
    rw mem_image, conv {congr, congr, funext, conv {congr, skip, dsimp, }} }, rw mem_image,
    split,
    { rintro ⟨⟨⟨y,hy⟩,⟨⟨⟨z,hz⟩,⟨hzX,hy'⟩⟩,h'⟩ ⟩,hxD⟩,
      dsimp only at h', subst h',
      exact ⟨⟨z,hz⟩,⟨hzX,by {by {simp at hy', assumption, }, }⟩⟩},
    rintro ⟨⟨y,hy⟩,⟨hyx,rfl⟩⟩,
    refine ⟨⟨⟨i.equiv y, _⟩ ,_⟩,nonmem_of_mem_disjoint hy P.NE_inter_D⟩,
    { simp only with msimp,
      rwa [diff_diff, ←image_union, P.union, coe_E, univ_diff, univ_diff, equiv.image_compl,
      compl_compl, equiv.image_mem_image_iff_mem], },
    refine ⟨⟨⟨y,hy⟩,hyx,_⟩,rfl⟩,
    rw subtype.mk_eq_mk, refl,
  end⟩

def image_minor_iso_minor {N M : matroid_in α} {M' : matroid_in β}
(i : isom M M') (P : minor_pair N M) :
  isom N (M' / (i.equiv '' (coe ⁻¹' P.C)) \ (i.equiv '' (coe ⁻¹' P.D))) :=
let iN := minor_isom_minor_as_mat P,
    iN' := minor_isom_minor_as_mat (image_minor_pair i P),
    P' := minor_pair_to_as_mat P,
    i' := minor_matroid_to_minor_iso P' i in
    have h : (
      ↑(M'.as_mat) / ⇑(i.equiv) '' P'.C \ ⇑(i.equiv) '' P'.D
          = (M'.as_mat : matroid_in M'.E)
              / coe ⁻¹' (image_minor_pair i P).C
              \ coe ⁻¹' (image_minor_pair i P).D) :=
      by {dsimp only [P', minor_pair_to_as_mat, image_minor_pair, cd_pair.to_as_mat,
          cd_pair.from_as_mat, image_cd_pair],
          unfold_coes, congr; {ext, simp,}},
  (iN.trans (matroid_in.isom_equiv rfl h i')).trans iN'.symm

end matroid_in.minor_pair

namespace matroid

open matroid_in.minor_pair

variables {α β γ : Type*}
[fintype α] [fintype β] [fintype γ]

/-- an embedding of N into M as a minor-/
@[ext] structure minor_emb (N : matroid β) (M : matroid α) :=
{N' : matroid_in α}
(P  : minor_pair N' M)
(i  : isom_to_matroid N' N)

@[ext] structure con_emb (N : matroid β) (M : matroid α) :=
(e : β ↪ α)
(C : set α)
(disj : disjoint (range e) C)
(on_rank : ∀ X : set β, N.r X = M.r (e '' X ∪ C) - M.r C)

def minor_emb.to_con_emb {N : matroid β} {M : matroid α} (me : minor_emb N M) : con_emb N M :=
{ e := ⟨λ v, me.i.equiv.symm v, λ v v' hvv', by simpa using subtype.val_injective hvv'⟩,
  C := me.P.C,
  disj := by {
    simp only [disjoint_iff_inter_eq_empty], ext,
    simp only [not_exists, mem_empty_eq, mem_inter_eq, not_and, mem_range,
      function.embedding.coe_fn_mk, iff_false, equiv.inv_fun_as_coe, to_cd_pair_as_coe,
      exists_imp_distrib],
    rintros y rfl hxy,
    cases me.i.equiv.symm y with z hz,
    exact ne_empty_iff_has_mem.mpr ⟨_,(mem_inter hz hxy)⟩ me.P.NE_inter_C, },
  on_rank := λ X, by {
    cases me with N' P i, dsimp only,
    rw [←i.symm.on_rank, as_mat_r, P.rank_subtype, coe_r], congr',
    unfold_coes, ext,
    simp only [mem_image, equiv.to_fun_as_coe, equiv.apply_eq_iff_eq, set_coe.exists,
      exists_and_distrib_right, exists_eq_right, subtype.coe_mk, subtype.val_eq_coe,
      equiv.inv_fun_as_coe],
    split,
    { rintros ⟨hx,y,hy,hy'⟩, refine ⟨y,hy,_⟩, dsimp only [isom.symm] at hy', rw hy', refl,  },
    rintros ⟨y, hy, rfl⟩, exact ⟨((i.equiv.symm) y).property,y,⟨hy, by {ext, refl}⟩⟩,
  } }

def con_emb.to_minor_emb {N : matroid β} {M : matroid α} (ce : con_emb N M) : (minor_emb N M) :=
{
  P := minor_pair.of_contract_restrict
    (M : matroid_in α)
    (subset_univ ce.C)
    (by {rw [univ_diff, ←disjoint_iff_subset_compl, ← disjoint_iff_inter_eq_empty],
          exact ce.disj, } : range ce.e ⊆ univ \ ce.C),
  i :=
  let e1 := equiv.set.range ce.e ce.e.inj',
      h := @contr_restr_E _ _ (M : matroid_in α) ce.C (range ce.e)
        (by {rw [coe_E, univ_diff, ←disjoint_iff_subset_compl, ← disjoint_iff_inter_eq_empty],
          exact ce.disj}),
      e2 := (equiv.set.of_eq h).symm in
  matroid.isom.symm ⟨e1.trans e2, λ X,
  begin
    simp only [e1,e2, as_mat_r] with msimp,
    rw ce.on_rank, congr, unfold_coes, ext,
    simp only [mem_image, equiv.to_fun_as_coe, exists_prop, mem_range_self, restr_E,
      equiv.set.range_apply, con_E, mem_inter_eq, set_coe.exists, mem_range,
      function.embedding.to_fun_eq_coe, function.comp_app, subtype.mk_eq_mk, equiv.coe_trans,
      equiv.set.of_eq_symm_apply, subtype.coe_mk, coe_E, univ_diff, mem_compl_eq,
      subtype.val_eq_coe],
    split, {rintro ⟨⟨_,-, h,rfl⟩,-,-⟩, exact h},
    rintro ⟨v,hv,rfl⟩,  refine ⟨⟨ce.e v,⟨⟨_,⟨_,rfl⟩⟩,⟨⟨_,hv,rfl⟩,rfl⟩⟩⟩,⟨v,rfl⟩⟩,
    exact nonmem_of_mem_disjoint (mem_range_self _) (disjoint_iff_inter_eq_empty.mp ce.disj),
  end⟩}

lemma con_emb.rank_le_rank_image {N : matroid β} {M : matroid α} (emb : con_emb N M) (X : set β) :
  N.r X ≤ M.r (emb.e '' X) :=
by {rw emb.on_rank, linarith [M.rank_subadditive (emb.e '' X) emb.C ]}

lemma con_emb.nonloop_of_nonloop {N : matroid β} {M : matroid α} (emb : con_emb N M)
{x : β} (he : N.is_nonloop x) :
  M.is_nonloop (emb.e x) :=
nonloop_of_one_le_rank
  (by {rw [←rank_nonloop he, ← image_singleton], apply emb.rank_le_rank_image, })

/-- an embedding of N into M as a restriction -/
@[ext] structure restr_emb (N : matroid β) (M : matroid α) :=
{N' : matroid_in α}
(P  : minor_pair N' M)
(hP : P.C = ∅)
(i  : isom_to_matroid N' N)

@[ext] structure inj_emb (N : matroid β) (M : matroid α) :=
(e : β ↪ α)
(on_rank : ∀ X : set β, N.r X = M.r (e '' X))

def restr_emb.to_inj_emb {N : matroid β} {M : matroid α} (re : restr_emb N M) : inj_emb N M :=
{ e := ⟨λ v, re.i.equiv.symm v, λ v v' hvv', by simpa using subtype.val_injective hvv'⟩,
  on_rank := λ X, by {
    simp only [← re.i.symm.on_rank, as_mat_r, re.P.rank_subtype, coe_r, re.hP, rank_empty, sub_zero,
    isom.symm, union_empty], unfold_coes, rw [←image_comp], }}

def inj_emb.to_restr_emb {N : matroid β} {M : matroid α} {ie : inj_emb N M } : restr_emb N M :=
{ P := minor_pair.of_restrict (M : matroid_in α) (subset_univ (range ie.e)),
  hP := rfl,
  i :=
  let e1 := equiv.set.range ie.e ie.e.inj',
      e2 := (equiv.set.of_eq (by simp : range ie.e = (↑M ∣ range ⇑(ie.e)).E)) in
  matroid.isom.symm ⟨e1.trans e2, λ X, begin
    simp only [ie.on_rank, as_mat_r, equiv.image_trans, e1, e2] with msimp,
    congr, unfold_coes, ext,
    simp only [mem_image, equiv.to_fun_as_coe, exists_prop, mem_range_self,
    equiv.set.of_eq_apply, restr_E, equiv.set.range_apply, mem_inter_eq, set_coe.exists, mem_range,
    function.embedding.to_fun_eq_coe, eq_self_iff_true, subtype.mk_eq_mk, exists_exists_and_eq_and,
    exists_exists_eq_and, exists_and_distrib_left, exists_true_left, subtype.coe_mk, coe_E,
    univ_inter, subtype.val_eq_coe, exists_apply_eq_apply],
    split; tidy,
  end ⟩ }

def restr_emb.to_minor_emb {N : matroid β} {M : matroid α} (re : restr_emb N M) :
  minor_emb N M :=
⟨re.P, re.i⟩

/-- the property of N being isomorphic to a minor of M-/
def is_iminor_of (N : matroid β) (M : matroid α) := nonempty (minor_emb N M)

/-- the property of N being isomorphic to a restriction of M -/
def is_irestr_of (N : matroid β) (M : matroid α) := nonempty (restr_emb N M)

lemma iminor_of_iff (N : matroid β) (M : matroid α) :
  N.is_iminor_of M ↔ ∃ (N' : matroid_in α), N'.is_minor M ∧ N'.is_isom_to_matroid N :=
by {split, rintros ⟨N',P,i⟩, exact ⟨N',⟨P⟩,⟨i⟩⟩, rintros ⟨N',⟨P⟩,⟨i⟩⟩, exact ⟨⟨P,i⟩⟩}

lemma irestr_of_iff (N : matroid β) (M : matroid α) :
  N.is_irestr_of M ↔ ∃ (M' : matroid_in α), M'.is_restriction M ∧ M'.is_isom_to_matroid N :=
by {split, rintros ⟨N',P,hP,i⟩, exact ⟨N',⟨P,hP⟩,⟨i⟩⟩, rintros ⟨N',⟨P,hP⟩,⟨i⟩⟩, exact ⟨⟨P,hP,i⟩⟩}

lemma iminor_of_iff_exists_embedding {N : matroid β} {M : matroid α} :
  N.is_iminor_of M ↔ ∃ (φ : β ↪ α) (C : set α), disjoint (set.range φ) C
                         ∧ ∀ X, N.r X = M.r (φ '' X ∪ C) - M.r C :=
begin
  simp_rw [iminor_of_iff, matroid_in.isom_to_matroid_iff_exists_embedding],
  split,
  { rintros ⟨M,⟨P⟩, ⟨φ, ⟨hrange, hr⟩⟩⟩,
    refine ⟨φ, P.C,_, λ X, _⟩,
    { rw hrange, exact P.NE_disj_C, },
    { rw [hr X, P.rank (φ '' X) (by {rw ←hrange, apply image_subset_range})], refl, }},
  rintros ⟨φ,C, hrange, hr⟩,
  rw [disjoint_iff_inter_eq_empty, disjoint_iff_inter_compl_eq_left, inter_comm] at hrange,
  exact ⟨((M : matroid_in α) / C) ∣
    range φ,
    matroid_in.con_restr_is_minor _ _ _,
    φ,
    ⟨by simp [hrange],
    λ X, by simp [hr X, subset_iff_inter_eq_left.mp (image_subset_range φ X)]⟩⟩,
end

lemma iminor_of_iff_exists_good_C {N : matroid β} {M : matroid α} :
  N.is_iminor_of M ↔ ∃ (φ : β ↪ α) (C : set α),
                           (set.range φ) ∩ C = ∅
                         ∧ (∀ X, N.r X = M.r (φ '' X ∪ C) - M.r C)
                         ∧ M.is_indep C
                         ∧ N.r univ = M.r univ - M.r C :=
begin
  simp_rw [iminor_of_iff, matroid_in.isom_to_matroid_iff_exists_embedding],
  split,
  { rintros ⟨M',h_minor, ⟨φ, ⟨hrange, hr⟩⟩⟩,
    obtain ⟨P,⟨hPi,hPs⟩⟩ := matroid_in.minor_pair.minor_has_indep_coindep_pair' h_minor,
    rw matroid_in.indep_iff_coe at hPi,
    refine ⟨φ, P.C,_, λ X, _, hPi ,_⟩,
    { rw hrange, exact P.NE_inter_C, },
    { rw [hr X, P.rank (φ '' X) (by {rw ←hrange, apply image_subset_range})], refl},
    simp only [←indep_iff_r.mp hPi] with msimp at hPs,
    rw [hPs, hr univ, image_univ, hrange], simp, },
  rintros ⟨φ,C, hrange, hr⟩,
  rw [disjoint_iff_inter_compl_eq_left, inter_comm] at hrange,
  exact ⟨((M : matroid_in α) / C) ∣
    range φ,
    matroid_in.con_restr_is_minor _ _ _,
    φ,
    ⟨by simp [hrange],
    λ X, by {simp [hr.1 X, subset_iff_inter_eq_left.mp (image_subset_range φ X)],}, ⟩⟩,
end

lemma iminor_of_iff_exists_con_emb {N : matroid β} {M : matroid α} :
  N.is_iminor_of M ↔ nonempty (con_emb N M) :=
begin
  rw is_iminor_of, split,
  { rintro ⟨me⟩, exact ⟨me.to_con_emb⟩, },
  { rintro ⟨ce⟩, exact ⟨ce.to_minor_emb⟩, },
end

lemma iminor_of_iff_exists_good_con_emb {N : matroid β} {M : matroid α} :
  N.is_iminor_of M ↔ ∃ em : con_emb N M, (M.is_indep em.C ∧ M.r em.C = M.r univ - N.r univ) :=
begin
  split, swap, rintros ⟨em,h₁,h₂⟩, exact ⟨em.to_minor_emb⟩,
  rintro ⟨em⟩,
  obtain ⟨P',⟨hPi,hPs⟩⟩ := matroid_in.minor_pair.minor_has_indep_coindep_pair' ⟨em.P⟩,
  refine ⟨(minor_emb.to_con_emb ⟨P',em.i⟩),_,_⟩; dsimp [minor_emb.to_con_emb],
  {simpa using hPi},
  convert hPs using 1, unfold_coes, rw [←indep_iff_r], simpa using hPi,
  convert rfl,
  rw [← em.i.symm.on_rank, as_mat_r],
  apply congr_arg, simp only [equiv.range_eq_univ, set.image_univ], unfold_coes, simp,
end

lemma irestr_of_iff_exists_map {N : matroid β} {M : matroid α} :
  N.is_irestr_of M ↔ ∃ (φ : β ↪ α), ∀ X, N.r X = M.r (φ '' X) :=
begin
  simp_rw [irestr_of_iff, matroid_in.isom_to_matroid_iff_exists_embedding],
  split,
  { rintros ⟨M', ⟨P,hC⟩, ⟨φ, hrange,hr⟩ ⟩,
    refine ⟨φ, λ X, _⟩,
    specialize hr X,
    rw [matroid_in.minor_pair.rank P, hC] at hr, convert hr, simp,
    rw ←hrange, apply image_subset_range, },
  rintros ⟨φ, hr⟩,
  refine ⟨(M : matroid_in α) ∣ range φ, matroid_in.restriction_to_is_restriction _ _,φ, ⟨_,λ X, _⟩⟩,
    simp,
  rw hr X, simp [subset_iff_inter_eq_left.mp (image_subset_range _ _)],
end

lemma iminor_refl (M : matroid α) :
  M.is_iminor_of M :=
iminor_of_iff_exists_embedding.mpr ⟨function.embedding.refl _,∅,by simp,λ X, by simp⟩

def minor_emb_of_isom_of_minor_emb {N : matroid α} {N' : matroid β} {M : matroid γ}
(i : N.isom N' ) (e : N'.minor_emb M) :
  N.minor_emb M :=
⟨e.P, e.i.trans i.symm⟩

def minor_emb_of_minor_emb_of_isom {N : matroid α} {M' : matroid β} {M : matroid γ}
(e : N.minor_emb M' ) (i : M'.isom M) :
  N.minor_emb M :=
{ N' := (M : matroid_in γ) / (i.equiv '' e.P.C) \ (i.equiv '' e.P.D),
  P := (M : matroid_in γ).to_minor_pair (i.equiv '' e.P.C) (i.equiv '' e.P.D),
  i := isom_to_matroid_of_isom ((e.P.minor_matroid_to_minor_iso i).symm.trans
                                                  (isom_of_isom_to_matroid e.i))}

lemma iminor_of_irestr {N : matroid α} {M : matroid β} (h : N.is_irestr_of M) :
  N.is_iminor_of M :=
let ⟨re⟩ := h in ⟨restr_emb.to_minor_emb re⟩

lemma iminor_of_isom_iminor {N : matroid α} {N' : matroid β} {M : matroid γ}
(hNN' : N.is_isom N' ) (hN'M : N'.is_iminor_of M) :
  N.is_iminor_of M :=
begin
  unfold is_iminor_of is_isom at *,
  obtain ⟨⟨i⟩,⟨e⟩⟩ := ⟨hNN', hN'M⟩,
  have := minor_emb_of_isom_of_minor_emb,
  exact ⟨this i e⟩ ,
end

lemma iminor_of_iminor_isom {N : matroid α} {M : matroid β} {M' : matroid γ}
(hNM : N.is_iminor_of M) (hMM' : M.is_isom M') :
  N.is_iminor_of M' :=
begin
  unfold is_iminor_of is_isom at *,
  obtain ⟨⟨i⟩,⟨e⟩⟩ := ⟨hMM', hNM⟩,
  have := minor_emb_of_minor_emb_of_isom,
  exact ⟨this e i⟩,
end

def iminor_emb_of_minor_pair {N M : matroid_in α} (P : N.minor_pair M) :
  N.as_mat.minor_emb M.as_mat :=
⟨P.minor_pair_to_as_mat, P.minor_isom_minor_as_mat.symm⟩

def minor_emb.trans {L : matroid α} {M : matroid β} {N : matroid γ}
  (eLM : minor_emb L M) (eMN : minor_emb M N) :
minor_emb L N :=
let ⟨e₁,C₁,h₁,hr₁⟩ := eLM.to_con_emb,
    ⟨e₂,C₂,h₂,hr₂⟩ := eMN.to_con_emb in
con_emb.to_minor_emb ({
  e := e₁.trans e₂,
  C := (e₂ '' C₁) ∪ C₂,
  disj := by {rw [disjoint_iff_inter_eq_empty, inter_distrib_left,
                          union_empty_iff, function.embedding.trans],
    unfold_coes at ⊢ h₁ h₂, dsimp only,  split,
    { rwa [range_comp, image_inter e₂.inj', image_eq_empty, ← disjoint_iff_inter_eq_empty]},
    rw disjoint_iff_inter_eq_empty at h₂,
    exact disjoint_of_subset_left' (range_comp_subset_range _ _) h₂, },
  on_rank := λ X,
  begin
    rw [hr₁, hr₂, hr₂], ring,
    rw [neg_add_eq_sub, image_union, ←union_assoc, function.embedding.trans],
    unfold_coes, rw ←image_comp,
  end
})

lemma iminor_trans {L : matroid α} {M : matroid β} {N : matroid γ}
(hLM : L.is_iminor_of M) (hMN : M.is_iminor_of N) :
L.is_iminor_of N :=
begin
  unfold is_iminor_of at *,
  obtain ⟨⟨e₁⟩,⟨e₂⟩⟩ := ⟨hLM, hMN⟩,
  have := minor_emb.trans,
  exact ⟨this e₁ e₂⟩,
end

/-- the property of having an N-minor -/
def has_iminor (M : matroid α) (N : matroid β) :=
  N.is_iminor_of M

/-- the property of having an N-restriction -/
def has_irestr (M : matroid α) (N : matroid β) :=
  N.is_irestr_of M

end matroid


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

/-!
# Lexicographic ordering of lists.

The lexicographic order on `list α` is defined by `L < M` iff
* `[] < (a :: L)` for any `a` and `L`,
* `(a :: L) < (b :: M)` where `a < b`, or
* `(a :: L) < (a :: M)` where `L < M`.

## See also

Related files are:
* `data.finset.colex`: Colexicographic order on finite sets.
* `data.psigma.order`: Lexicographic order on `Σ' i, α i`.
* `data.pi.lex`: Lexicographic order on `Πₗ i, α i`.
* `data.sigma.order`: Lexicographic order on `Σ i, α i`.
* `data.prod.lex`: Lexicographic order on `α × β`.
-/

namespace list

open nat

universes u

variables {α : Type u}

/-! ### lexicographic ordering -/

/-- Given a strict order `<` on `α`, the lexicographic strict order on `list α`, for which
`[a0, ..., an] < [b0, ..., b_k]` if `a0 < b0` or `a0 = b0` and `[a1, ..., an] < [b1, ..., bk]`.
The definition is given for any relation `r`, not only strict orders. -/
inductive lex (r : α → α → Prop) : list α → list α → Prop
| nil {a l} : lex [] (a :: l)
| cons {a l₁ l₂} (h : lex l₁ l₂) : lex (a :: l₁) (a :: l₂)
| rel {a₁ l₁ a₂ l₂} (h : r a₁ a₂) : lex (a₁ :: l₁) (a₂ :: l₂)

namespace lex
theorem cons_iff {r : α → α → Prop} [is_irrefl α r] {a l₁ l₂} :
  lex r (a :: l₁) (a :: l₂) ↔ lex r l₁ l₂ :=
⟨λ h, by cases h with _ _ _ _ _ h _ _ _ _ h;
  [exact h, exact (irrefl_of r a h).elim], lex.cons⟩

@[simp] theorem not_nil_right (r : α → α → Prop) (l : list α) : ¬ lex r l [].

instance is_order_connected (r : α → α → Prop)
  [is_order_connected α r] [is_trichotomous α r] :
  is_order_connected (list α) (lex r) :=
⟨λ l₁, match l₁ with
| _,     [],    c::l₃, nil    := or.inr nil
| _,     [],    c::l₃, rel _ := or.inr nil
| _,     [],    c::l₃, cons _ := or.inr nil
| _,     b::l₂, c::l₃, nil := or.inl nil
| a::l₁, b::l₂, c::l₃, rel h :=
  (is_order_connected.conn _ b _ h).imp rel rel
| a::l₁, b::l₂, _::l₃, cons h := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match _ l₂ _ h).imp cons cons },
    { exact or.inr (rel ab) }
  end
end⟩

instance is_trichotomous (r : α → α → Prop) [is_trichotomous α r] :
  is_trichotomous (list α) (lex r) :=
⟨λ l₁, match l₁ with
| [], [] := or.inr (or.inl rfl)
| [], b::l₂ := or.inl nil
| a::l₁, [] := or.inr (or.inr nil)
| a::l₁, b::l₂ := begin
    rcases trichotomous_of r a b with ab | rfl | ab,
    { exact or.inl (rel ab) },
    { exact (_match l₁ l₂).imp cons
      (or.imp (congr_arg _) cons) },
    { exact or.inr (or.inr (rel ab)) }
  end
end⟩

instance is_asymm (r : α → α → Prop)
  [is_asymm α r] : is_asymm (list α) (lex r) :=
⟨λ l₁, match l₁ with
| a::l₁, b::l₂, lex.rel h₁, lex.rel h₂ := asymm h₁ h₂
| a::l₁, b::l₂, lex.rel h₁, lex.cons h₂ := asymm h₁ h₁
| a::l₁, b::l₂, lex.cons h₁, lex.rel h₂ := asymm h₂ h₂
| a::l₁, b::l₂, lex.cons h₁, lex.cons h₂ :=
  by exact _match _ _ h₁ h₂
end⟩

instance is_strict_total_order (r : α → α → Prop)
  [is_strict_total_order' α r] : is_strict_total_order' (list α) (lex r) :=
{..is_strict_weak_order_of_is_order_connected}

instance decidable_rel [decidable_eq α] (r : α → α → Prop)
  [decidable_rel r] : decidable_rel (lex r)
| l₁ [] := is_false $ λ h, by cases h
| [] (b::l₂) := is_true lex.nil
| (a::l₁) (b::l₂) := begin
  haveI := decidable_rel l₁ l₂,
  refine decidable_of_iff (r a b ∨ a = b ∧ lex r l₁ l₂) ⟨λ h, _, λ h, _⟩,
  { rcases h with h | ⟨rfl, h⟩,
    { exact lex.rel h },
    { exact lex.cons h } },
  { rcases h with _|⟨_,_,_,h⟩|⟨_,_,_,_,h⟩,
    { exact or.inr ⟨rfl, h⟩ },
    { exact or.inl h } }
end

theorem append_left (R : α → α → Prop) {t₁ t₂} (h : lex R t₁ t₂) :
  ∀ s, lex R (s ++ t₁) (s ++ t₂)
| []      := h
| (a::l) := cons (append_left l)

theorem imp {r s : α → α → Prop} (H : ∀ a b, r a b → s a b) :
  ∀ l₁ l₂, lex r l₁ l₂ → lex s l₁ l₂
| _ _ nil      := nil
| _ _ (cons h) := cons (imp _ _ h)
| _ _ (rel r)  := rel (H _ _ r)

theorem to_ne : ∀ {l₁ l₂ : list α}, lex (≠) l₁ l₂ → l₁ ≠ l₂
| _ _ (cons h) e := to_ne h (list.cons.inj e).2
| _ _ (rel r)  e := r (list.cons.inj e).1

theorem _root_.decidable.list.lex.ne_iff [decidable_eq α]
  {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
⟨to_ne, λ h, begin
  induction l₁ with a l₁ IH generalizing l₂; cases l₂ with b l₂,
  { contradiction },
  { apply nil },
  { exact (not_lt_of_ge H).elim (succ_pos _) },
  { by_cases ab : a = b,
    { subst b, apply cons,
      exact IH (le_of_succ_le_succ H) (mt (congr_arg _) h) },
    { exact rel ab } }
end⟩

theorem ne_iff {l₁ l₂ : list α} (H : length l₁ ≤ length l₂) : lex (≠) l₁ l₂ ↔ l₁ ≠ l₂ :=
by classical; exact decidable.list.lex.ne_iff H

end lex

--Note: this overrides an instance in core lean
instance has_lt' [has_lt α] : has_lt (list α) := ⟨lex (<)⟩

theorem nil_lt_cons [has_lt α] (a : α) (l : list α) : [] < a :: l :=
lex.nil

instance [linear_order α] : linear_order (list α) :=
linear_order_of_STO' (lex (<))

--Note: this overrides an instance in core lean
instance has_le' [linear_order α] : has_le (list α) :=
preorder.to_has_le _

end list


/- Exercise 3.2: Program Semantics — Hoare Logic -/

/- Download `x32_library.lean` from the "Logical Verification" homepage and put it in the same
directory as this exercise sheet. -/

import .x32_library

namespace lecture

/- Background material from the lecture. Do not prove the `sorry`s below. -/

def program.while_inv (I : state → Prop) (c : state → Prop) (p : program) : program :=
program.while c p

open program

variables
  {c : state → Prop} {f : state → ℕ} {n : string}
  {p p₀ p₁ p₂ : program} {s s₀ s₁ s₂ t u : state}
  {P P' P₁ P₂ P₃ Q Q' : state → Prop}

def partial_hoare (P : state → Prop) (p : program) (Q : state → Prop) : Prop :=
∀s t, P s → (p, s) ⟹ t → Q t

notation `{* ` P : 1 ` *} ` p : 1 ` {* ` Q : 1 ` *}` := partial_hoare P p Q

namespace partial_hoare

lemma consequence (h : {* P *} p {* Q *}) (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  {* P' *} p {* Q' *} :=
begin
  intros s t ps pst,
  apply hq,
  apply h s,
  apply hp,
  repeat{assumption}
end

lemma consequence_left (P' : state → Prop) (h : {* P *} p {* Q *}) (hp : ∀s, P' s → P s) :
  {* P' *} p {* Q *} :=
begin
  intros s t ps pst,
  apply h s,
  apply hp,
  repeat{assumption}
end

lemma consequence_right (Q : state → Prop) (h : {* P *} p {* Q *}) (hq : ∀s, Q s → Q' s) :
  {* P *} p {* Q' *} :=
begin
  intros s t ps pst,
  apply hq t,
  apply h s,
  repeat{assumption}
end

lemma skip_intro :
  {* P *} skip {* P *} :=
begin
  intros s t ps pst,
  cases pst,
  assumption
end

lemma assign_intro (P : state → Prop) :
  {* λs, P (s.update n (f s)) *} assign n f {* P *} :=
begin
  intros s t p nfs,
  cases nfs,
  assumption
end

lemma seq_intro (h₁ : {* P₁ *} p₁ {* P₂ *}) (h₂ : {* P₂ *} p₂ {* P₃ *}) :
  {* P₁ *} seq p₁ p₂ {* P₃ *} :=
  begin
    intros s t P hst,
  cases hst,
  apply h₂ s,
  apply h₁ hst_t,
  apply h₂ hst_t _ hst_h₂,

  end

lemma ite_intro (h₁ : {* λs, P s ∧ c s *} p₁ {* Q *}) (h₂ : {* λs, P s ∧ ¬ c s *} p₂ {* Q *}) :
  {* P *} ite c p₁ p₂ {* Q *} :=
  begin
    intros s t pst itc,
    cases itc,
    apply h₁ s,
    apply and.intro,
    repeat{assumption},
    apply h₂ s,
    apply and.intro,
    repeat{assumption}
  end

lemma unless_intro (h₁ : {* λs, P s ∧ ¬ c s  *} p {* Q *} ) :
  {* P *} unless p c {* Q *} :=
  begin
    intros s t pst itc,
    cases itc,
    apply h₁ s,
    apply and.intro,
    repeat{assumption}
  end

lemma do_while_intro (h₁ : {* P *} p {* P *} ) (h₂ : {* P *} p {* λs, P s ∧ c s *} ) :
  {* P *} do_while p c {* λs, P s ∧ ¬ c s *} :=
  begin
    intros s t pst itc,
    apply and.intro,
    apply h₁ s,
    assumption,
    cases itc,

  end

lemma while_intro (P : state → Prop) (h₁ : {* λs, P s ∧ c s *} p {* P *}) :
  {* P *} while c p {* λs, P s ∧ ¬ c s *} :=
  begin
    intros s t ps cpt,
    apply and.intro,
    cases cpt,
    repeat{assumption},
    apply h₁ s,
    apply and.intro,
    repeat{assumption},
    apply big_step.while_true cpt_t cpt_hp ,
  end

lemma skip_intro' (h : ∀s, P s → Q s):
  {* P *} skip {* Q *} :=
sorry

lemma assign_intro' (h : ∀s, P s → Q (s.update n (f s))):
  {* P *} assign n f {* Q *} :=
sorry

lemma seq_intro' (h₂ : {* P₂ *} p₂ {* P₃ *}) (h₁ : {* P₁ *} p₁ {* P₂ *}) :
  {* P₁ *} p₁ ;; p₂ {* P₃ *} :=
sorry

lemma while_intro_inv (I : state → Prop)
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hp : ∀s, P s → I s) (hq : ∀s, ¬ c s → I s → Q s) :
  {* P *} while c p {* Q *} :=
sorry

lemma while_inv_intro {I : state → Prop}
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hq : ∀s, ¬ c s → I s → Q s) :
  {* I *} while_inv I c p {* Q *} :=
sorry

lemma while_inv_intro' {I : state → Prop}
  (h₁ : {* λs, I s ∧ c s *} p {* I *}) (hp : ∀s, P s → I s) (hq : ∀s, ¬ c s → I s → Q s) :
  {* P *} while_inv I c p {* Q *} :=
sorry

end partial_hoare

end lecture

namespace tactic.interactive

open lecture.partial_hoare lecture tactic

meta def is_meta {elab : bool} : expr elab → bool
| (expr.mvar _ _ _) := tt
| _                 := ff

meta def vcg : tactic unit := do
  `({* %%P *} %%p {* %%Q *}) ← target
  | skip, -- do nothing if the goal is not a Hoare triple
match p with
| `(program.skip)            := applyc (if is_meta P then ``skip_intro else ``skip_intro')
| `(program.assign _ _)      := applyc (if is_meta P then ``assign_intro else ``assign_intro')
| `(program.ite _ _ _)       := do applyc ``ite_intro; vcg
| `(program.seq _ _)         := do applyc ``seq_intro'; vcg
| `(program.while_inv _ _ _) :=
  do applyc (if is_meta P then ``while_inv_intro else ``while_inv_intro'); vcg
| _                          := fail (to_fmt "cannot analyze " ++ to_fmt p)

end

end tactic.interactive

namespace lecture

open program partial_hoare

/- Question 1: Program verification -/

section GAUSS

/- The following WHILE program is intended to compute the Gaussian sum up to `n`, leaving the result
in `r`. -/

def GAUSS : program :=
assign "r" (λs, 0) ;;
while (λs, s "n" ≠ 0)
( assign "r" (λs, s "r" + s "n") ;;
  assign "n" (λs, s "n" - 1) )

/- The summation function: -/

def sum_upto : ℕ → ℕ
| 0       := 0
| (n + 1) := n + 1 + sum_upto n

/- 1.1. Prove the correctness of `GAUSS`, using `vcg`. The main challenge is to figure out which
invariant to use for the while loop. The invariant should capture both the work that has been done
already (the intermediate result) and the work that remains to be done. -/

lemma GAUSS_correct (n : ℕ) :
  {* λs, s "n" = n *} GAUSS {* λs, s "r" = sum_upto n *} :=
begin
intros s t sn gaus,
cases sn,
cases gaus,
cases gaus_h₂ ,
cases gaus_h₂_hw ,
vcg,

end

end GAUSS

section MUL

/- The following WHILE program is intended to compute the product of `n` and `m`, leaving the
result in `r`. -/

def MUL : program :=
assign "r" (λs, 0) ;;
while (λs, s "n" ≠ 0)
( assign "r" (λs, s "r" + s "m") ;;
  assign "n" (λs, s "n" - 1) )

/- 1.2 Prove the correctness of `MUL`, using `vcg`.

Hint: If a variable `x` does not change in a program, it might be useful to record this in the
invariant, by adding a conjunct `s "x" = x`. -/

lemma MUL_correct (n m : ℕ) :
  {* λs, s "n" = n ∧ s "m" = m *} MUL {* λs, s "r" = n * m *} :=
sorry

end MUL

/- Question 2: Hoare triples for total correctness -/

def total_hoare (P : state → Prop) (p : program) (Q : state → Prop) : Prop :=
∀s, P s → ∃t, (p, s) ⟹ t ∧ Q t

notation `[* ` P : 1 ` *] ` p : 1 ` [* ` Q : 1 ` *]` := total_hoare P p Q

namespace total_hoare
variables {P P' P₁ P₂ P₃ Q Q' : state → Prop} {n : string}
variables {p p₀ p₁ p₂ : program}
variables {c : state → Prop} {f : state → ℕ}
  {s s₀ s₁ s₂ t u : state}

/- 2.1. Prove the consequence rule. -/

lemma consequence (h : [* P *] p [* Q *]) (hp : ∀s, P' s → P s) (hq : ∀s, Q s → Q' s) :
  [* P' *] p [* Q' *] :=
sorry

/- 2.2. Prove the rule for `skip`. -/

lemma skip_intro :
  [* P *] skip [* P *] :=
sorry

/- 2.3. Prove the rule for `assign`. -/

lemma assign_intro (P : state → Prop) :
  [* λs, P (s.update n (f s)) *] assign n f [* P *] :=
sorry

/- 2.4. Prove the rule for `seq`. -/

lemma seq_intro (h₁ : [* P₁ *] p₁ [* P₂ *]) (h₂ : [* P₂ *] p₂ [* P₃ *]) :
  [* P₁ *] p₁ ;; p₂ [* P₃ *] :=
sorry

/- 2.5. Prove the rule for `ite`. This requires `c s ∨ ¬ c s`. `classical.em (c s)` provides a
proof, even when `c` is not decidable. -/

lemma ite_intro (h₁ : [* λs, P s ∧ c s *] p₁ [* Q *]) (h₂ : [* λs, P s ∧ ¬ c s *] p₂ [* Q *]) :
  [* P *] ite c p₁ p₂ [* Q *] :=
sorry

/- 2.6. Try to prove the rule for `while`.

Before we prove our final goal, we introduce an auxiliary proof. This proof requires
well-founded induction. When using `while_intro.aux` as induction hypothesis we recommend
to do it directly after proving that the argument is less than `n`:

    have ih : ∃u, (while c p, t) ⟹ u ∧ I u ∧ ¬c u :=
      have M < n := ..., -- necessary for Lean to figure out the well-founded induction
      while_intro.aux M ...,

Similar to `ite`, this requires `c s ∨ ¬ c s`. `classical.em (c s)` provides a proof. -/

lemma while_intro.aux
  (I : state → Prop)
  (V : state → ℕ)
  (h_inv : ∀n, [* λs, I s ∧ c s ∧ V s = n *] p [* λs, I s ∧ V s < n *]) :
  ∀n s, V s = n → I s → ∃t, (while c p, s) ⟹ t ∧ I t ∧ ¬ c t
| n s V_eq hs :=
sorry

lemma while_intro
  (I : state → Prop)  -- invariant in the loop
  (V : state → ℕ)  -- variant in the loop body (a.k.a. termination measure)
  (h_inv : ∀n, [* λs, I s ∧ c s ∧ V s = n *] p [* λs, I s ∧ V s < n *]) :
  [* I *] while c p [* λs, I s ∧ ¬ c s *] :=
sorry

end total_hoare

end lecture


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Yaël Dillies, Bhavik Mehta
-/
import data.finset.lattice

/-!
# Finite sets in a sigma type

This file defines a few `finset` constructions on `Σ i, α i`.

## Main declarations

* `finset.sigma`: Given a finset `s` in `ι` and finsets `t i` in each `α i`, `s.sigma t` is the
  finset of the dependent sum `Σ i, α i`
* `finset.sigma_lift`: Lifts maps `α i → β i → finset (γ i)` to a map
  `Σ i, α i → Σ i, β i → finset (Σ i, γ i)`.

## TODO

`finset.sigma_lift` can be generalized to any alternative functor. But to make the generalization
worth it, we must first refactor the functor library so that the `alternative` instance for `finset`
is computable and universe-polymorphic.
-/

open function multiset

variables {ι : Type*}

namespace finset
section sigma
variables {α : ι → Type*} {β : Type*} (s s₁ s₂ : finset ι) (t t₁ t₂ : Π i, finset (α i))

/-- `s.sigma t` is the finset of dependent pairs `⟨i, a⟩` such that `i ∈ s` and `a ∈ t i`. -/
protected def sigma : finset (Σ i, α i) := ⟨_, nodup_sigma s.2 (λ i, (t i).2)⟩

variables {s s₁ s₂ t t₁ t₂}

@[simp] lemma mem_sigma {a : Σ i, α i} : a ∈ s.sigma t ↔ a.1 ∈ s ∧ a.2 ∈ t a.1 := mem_sigma

@[simp] lemma sigma_nonempty : (s.sigma t).nonempty ↔ ∃ i ∈ s, (t i).nonempty :=
by simp [finset.nonempty]

@[simp] lemma sigma_eq_empty : s.sigma t = ∅ ↔ ∀ i ∈ s, t i = ∅ :=
by simp only [← not_nonempty_iff_eq_empty, sigma_nonempty, not_exists]

@[mono] lemma sigma_mono (hs : s₁ ⊆ s₂) (ht : ∀ i, t₁ i ⊆ t₂ i) : s₁.sigma t₁ ⊆ s₂.sigma t₂ :=
λ ⟨i, a⟩ h, let ⟨hi, ha⟩ := mem_sigma.1 h in mem_sigma.2 ⟨hs hi, ht i ha⟩

lemma sigma_eq_bUnion [decidable_eq (Σ i, α i)] (s : finset ι) (t : Π i, finset (α i)) :
  s.sigma t = s.bUnion (λ i, (t i).map $ embedding.sigma_mk i) :=
by { ext ⟨x, y⟩, simp [and.left_comm] }

variables (s t) (f : (Σ i, α i) → β)

lemma sup_sigma [semilattice_sup β] [order_bot β] :
  (s.sigma t).sup f = s.sup (λ i, (t i).sup $ λ b, f ⟨i, b⟩) :=
begin
  refine (sup_le _).antisymm (sup_le $ λ i hi, sup_le $ λ b hb, le_sup $ mem_sigma.2 ⟨hi, hb⟩),
  rintro ⟨i, b⟩ hb,
  rw mem_sigma at hb,
  refine le_trans _ (le_sup hb.1),
  convert le_sup hb.2,
end

lemma inf_sigma [semilattice_inf β] [order_top β] :
  (s.sigma t).inf f = s.inf (λ i, (t i).inf $ λ b, f ⟨i, b⟩) :=
@sup_sigma _ _ (order_dual β) _ _ _ _ _

end sigma

section sigma_lift
variables {α β γ : ι → Type*} [decidable_eq ι]

/-- Lifts maps `α i → β i → finset (γ i)` to a map `Σ i, α i → Σ i, β i → finset (Σ i, γ i)`. -/
def sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i)) (a : sigma α) (b : sigma β) :
  finset (sigma γ) :=
dite (a.1 = b.1) (λ h, (f (h.rec a.2) b.2).map $ embedding.sigma_mk _) (λ _, ∅)

lemma mem_sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i))
  (a : sigma α) (b : sigma β) (x : sigma γ) :
  x ∈ sigma_lift f a b ↔ ∃ (ha : a.1 = x.1) (hb : b.1 = x.1), x.2 ∈ f (ha.rec a.2) (hb.rec b.2) :=
begin
  obtain ⟨⟨i, a⟩, j, b⟩ := ⟨a, b⟩,
  obtain rfl | h := decidable.eq_or_ne i j,
  { split,
    { simp_rw [sigma_lift, dif_pos rfl, mem_map, embedding.sigma_mk_apply],
      rintro ⟨x, hx, rfl⟩,
      exact ⟨rfl, rfl, hx⟩ },
    { rintro ⟨⟨⟩, ⟨⟩, hx⟩,
      rw [sigma_lift, dif_pos rfl, mem_map],
      exact ⟨_, hx, by simp [sigma.ext_iff]⟩ } },
  { rw [sigma_lift, dif_neg h],
    refine iff_of_false (not_mem_empty _) _,
    rintro ⟨⟨⟩, ⟨⟩, _⟩,
    exact h rfl }
end

lemma mk_mem_sigma_lift (f : Π ⦃i⦄, α i → β i → finset (γ i)) (i : ι) (a : α i) (b : β i)
  (x : γ i) :
  (⟨i, x⟩ : sigma γ) ∈ sigma_lift f ⟨i, a⟩ ⟨i, b⟩ ↔ x ∈ f a b :=
begin
  rw [sigma_lift, dif_pos rfl, mem_map],
  refine ⟨_, λ hx, ⟨_, hx, rfl⟩⟩,
  rintro ⟨x, hx, _, rfl⟩,
  exact hx,
end

lemma not_mem_sigma_lift_of_ne_left (f : Π ⦃i⦄, α i → β i → finset (γ i))
  (a : sigma α) (b : sigma β) (x : sigma γ) (h : a.1 ≠ x.1) :
  x ∉ sigma_lift f a b :=
by { rw mem_sigma_lift, exact λ H, h H.fst }

lemma not_mem_sigma_lift_of_ne_right (f : Π ⦃i⦄, α i → β i → finset (γ i))
  {a : sigma α} (b : sigma β) {x : sigma γ} (h : b.1 ≠ x.1) :
  x ∉ sigma_lift f a b :=
by { rw mem_sigma_lift, exact λ H, h H.snd.fst }

variables {f g : Π ⦃i⦄, α i → β i → finset (γ i)} {a : Σ i, α i} {b : Σ i, β i}

lemma sigma_lift_nonempty :
  (sigma_lift f a b).nonempty ↔ ∃ h : a.1 = b.1, (f (h.rec a.2) b.2).nonempty :=
begin
  simp_rw nonempty_iff_ne_empty,
  convert dite_ne_right_iff,
  ext h,
  simp_rw ←nonempty_iff_ne_empty,
  exact map_nonempty.symm,
end

lemma sigma_lift_eq_empty : (sigma_lift f a b) = ∅ ↔ ∀ h : a.1 = b.1, (f (h.rec a.2) b.2) = ∅ :=
begin
  convert dite_eq_right_iff,
  exact forall_congr_eq (λ h, propext map_eq_empty.symm),
end

lemma sigma_lift_mono (h : ∀ ⦃i⦄ ⦃a : α i⦄ ⦃b : β i⦄, f a b ⊆ g a b) (a : Σ i, α i) (b : Σ i, β i) :
  sigma_lift f a b ⊆ sigma_lift g a b :=
begin
  rintro x hx,
  rw mem_sigma_lift at ⊢ hx,
  obtain ⟨ha, hb, hx⟩ := hx,
  exact ⟨ha, hb, h hx⟩,
end

variables (f a b)

lemma card_sigma_lift :
  (sigma_lift f a b).card = dite (a.1 = b.1) (λ h, (f (h.rec a.2) b.2).card) (λ _, 0) :=
by { convert apply_dite _ _ _ _, ext h, exact (card_map _).symm }

end sigma_lift

end finset


import linear_algebra.tensor_product

import for_mathlib.AddCommGroup_instances
import for_mathlib.AddCommGroup.explicit_products
import for_mathlib.AddCommGroup.ab4
import for_mathlib.AddCommGroup
import for_mathlib.exact_filtered_colimits
import for_mathlib.split_exact
import for_mathlib.ab4
import for_mathlib.ab52
import category_theory.limits.preserves.limits

noncomputable theory

universes u
open_locale tensor_product

open category_theory

namespace AddCommGroup

def linear_equiv_to_iso {A B : AddCommGroup.{u}}
  (e : A ≃ₗ[ℤ] B) :
  A ≅ B :=
{ hom := e.to_linear_map.to_add_monoid_hom,
  inv := e.symm.to_linear_map.to_add_monoid_hom,
  hom_inv_id' := begin
    ext t,
    simp,
  end,
  inv_hom_id' := begin
    ext t,
    simp,
  end }

def tensor (A B : AddCommGroup.{u}) : AddCommGroup.{u} :=
AddCommGroup.of (A ⊗[ℤ] B)

lemma tensor_ext {A B C : AddCommGroup.{u}} (f g : A.tensor B ⟶ C)
  (h : ∀ x y, f (x ⊗ₜ y) = g (x ⊗ₜ y)) : f = g :=
begin
  ext1 x, show f.to_int_linear_map x = g.to_int_linear_map x, congr' 1, clear x,
  apply tensor_product.ext', exact h,
end

def tensor_uncurry {A B C : AddCommGroup.{u}}
  (e : A ⟶ AddCommGroup.of (B ⟶ C)) : tensor A B ⟶ C :=
linear_map.to_add_monoid_hom $ tensor_product.lift $
let e' := e.to_int_linear_map,
  e'' : (B ⟶ C) →ₗ[ℤ] (B →ₗ[ℤ] C) :=
  add_monoid_hom.to_int_linear_map
  { to_fun := λ f, f.to_int_linear_map,
    map_zero' := by { ext, refl },
    map_add' := λ f g, by { ext, refl } } in
e''.comp e'

def tensor_curry {A B C : AddCommGroup.{u}}
  (e : tensor A B ⟶ C) : A ⟶ AddCommGroup.of (B ⟶ C) :=
{ to_fun := λ a,
  { to_fun := λ b, e (a ⊗ₜ b),
    map_zero' := by { rw [tensor_product.tmul_zero, e.map_zero], },
    map_add' := begin
      intros b c,
      rw [tensor_product.tmul_add, e.map_add],
    end },
  map_zero' := begin
    ext t,
    dsimp,
    rw [tensor_product.zero_tmul, e.map_zero],
  end,
  map_add' := begin
    intros x y, ext t,
    dsimp,
    rw [tensor_product.add_tmul, e.map_add],
  end }

.

@[simps]
def tensor_curry_equiv (A B C : AddCommGroup.{u}) :
  (tensor A B ⟶ C) ≃+ (A ⟶ (AddCommGroup.of (B ⟶ C))) :=
{ to_fun := tensor_curry,
  inv_fun := tensor_uncurry,
  left_inv := begin
    intros f, apply tensor_ext, intros x y, dsimp only [tensor_uncurry, tensor_curry],
    erw [tensor_product.lift.tmul], refl,
  end,
  right_inv := λ f, by { ext, dsimp only [tensor_uncurry, tensor_curry],
    erw [tensor_product.lift.tmul], refl, },
  map_add' := λ x y, by { ext, refl } }

.

@[simp]
lemma tensor_curry_uncurry {A B C : AddCommGroup.{u}}
  (e : A ⟶ (AddCommGroup.of (B ⟶ C))) :
  tensor_curry (tensor_uncurry e) = e :=
(tensor_curry_equiv A B C).apply_symm_apply e

@[simp]
lemma tensor_uncurry_curry {A B C : AddCommGroup.{u}}
  (e : tensor A B ⟶ C) :
  tensor_uncurry (tensor_curry e) = e :=
(tensor_curry_equiv A B C).symm_apply_apply e

def map_tensor {A A' B B' : AddCommGroup.{u}}
  (f : A ⟶ A') (g : B ⟶ B') : tensor A B ⟶ tensor A' B' :=
(tensor_product.map f.to_int_linear_map g.to_int_linear_map).to_add_monoid_hom

lemma id_helper (A : AddCommGroup.{u}) :
  (𝟙 A : A ⟶ A).to_int_linear_map = linear_map.id := rfl

lemma comp_helper {A B C : AddCommGroup.{u}}
  (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).to_int_linear_map = g.to_int_linear_map.comp f.to_int_linear_map := rfl

@[simp]
lemma zero_helper {A B : AddCommGroup.{u}} :
  (0 : A ⟶ B).to_int_linear_map = 0 := rfl

@[simp]
lemma map_tensor_id {A B : AddCommGroup.{u}} :
  map_tensor (𝟙 A) (𝟙 B) = 𝟙 _ :=
begin
  ext t, dsimp [map_tensor], simp [id_helper],
end

@[simp]
lemma map_tensor_comp_left {A A' A'' B : AddCommGroup.{u}} (f : A ⟶ A') (g : A' ⟶ A'') :
  map_tensor (f ≫ g) (𝟙 B) = map_tensor f (𝟙 _) ≫ map_tensor g (𝟙 _) :=
begin
  ext t,
  rw ← category.id_comp (𝟙 B),
  dsimp [map_tensor], simp only [comp_helper, id_helper, tensor_product.map_comp],
  simp,
end

@[simp]
lemma map_tensor_comp_right {A B B' B'' : AddCommGroup.{u}} (f : B ⟶ B') (g : B' ⟶ B'') :
  map_tensor (𝟙 A) (f ≫ g) = map_tensor (𝟙 _) f ≫ map_tensor (𝟙 _) g :=
begin
  ext t,
  rw ← category.id_comp (𝟙 A),
  dsimp [map_tensor], simp only [comp_helper, id_helper, tensor_product.map_comp],
  simp,
end

@[simp]
lemma map_tensor_comp_comp {A A' A'' B B' B'' : AddCommGroup.{u}}
  (f : A ⟶ A') (f' : A' ⟶ A'') (g : B ⟶ B') (g' : B' ⟶ B'') :
  map_tensor (f ≫ f') (g ≫ g') = map_tensor f g ≫ map_tensor f' g' :=
begin
  ext t,
  dsimp [map_tensor], simp only [comp_helper, id_helper, tensor_product.map_comp],
  simp,
end

lemma map_tensor_eq_comp {A A' B B' : AddCommGroup.{u}} (f : A ⟶ A') (g : B ⟶ B') :
  map_tensor f g = map_tensor f (𝟙 _) ≫ map_tensor (𝟙 _) g :=
begin
  nth_rewrite 0 ← category.id_comp g,
  nth_rewrite 0 ← category.comp_id f,
  rw map_tensor_comp_comp,
end

lemma map_tensor_eq_comp' {A A' B B' : AddCommGroup.{u}} (f : A ⟶ A') (g : B ⟶ B') :
  map_tensor f g = map_tensor (𝟙 _) g ≫ map_tensor f (𝟙 _) :=
begin
  nth_rewrite 0 ← category.id_comp f,
  nth_rewrite 0 ← category.comp_id g,
  rw map_tensor_comp_comp,
end

@[simp]
lemma map_tensor_zero_left {A A' B B' : AddCommGroup.{u}} (f : B ⟶ B') :
  map_tensor (0 : A ⟶ A') f = 0 :=
begin
  apply (tensor_curry_equiv _ _ _).injective,
  ext a b,
  dsimp [tensor_curry, map_tensor],
  simp,
end

@[simp]
lemma map_tensor_zero_right {A A' B B' : AddCommGroup.{u}} (f : A ⟶ A') :
  map_tensor f (0 : B ⟶ B') = 0 :=
begin
  apply (tensor_curry_equiv _ _ _).injective,
  ext a b,
  dsimp [tensor_curry, map_tensor],
  simp,
end

@[simp]
lemma map_tensor_add_right {A A' B B' : AddCommGroup.{u}} (f : A ⟶ A') (g₁ g₂ : B ⟶ B') :
  map_tensor f (g₁ + g₂) = map_tensor f g₁ + map_tensor f g₂ :=
begin
  apply (tensor_curry_equiv _ _ _).injective,
  ext a b,
  dsimp [tensor_curry, map_tensor],
  apply tensor_product.tmul_add,
end

@[simp]
lemma map_tensor_add_left {A A' B B' : AddCommGroup.{u}} (f₁ f₂ : A ⟶ A') (g : B ⟶ B') :
  map_tensor (f₁ + f₂) g = map_tensor f₁ g + map_tensor f₂ g :=
begin
  apply (tensor_curry_equiv _ _ _).injective,
  ext a b,
  dsimp [tensor_curry, map_tensor],
  apply tensor_product.add_tmul,
end

lemma tensor_uncurry_comp_curry {A B C D : AddCommGroup.{u}} (f : A ⟶ B) (g : B.tensor C ⟶ D) :
  tensor_uncurry (f ≫ tensor_curry g) = map_tensor f (𝟙 _) ≫ g :=
begin
  apply (tensor_curry_equiv _ _ _).injective,
  erw (tensor_curry_equiv _ _ _).apply_symm_apply,
  ext a c,
  dsimp [tensor_curry, tensor_curry_equiv, map_tensor],
  simp,
end

lemma tensor_curry_uncurry_comp {A B C D : AddCommGroup.{u}}
  (e : A ⟶ AddCommGroup.of (B ⟶ C)) (g : C ⟶ D):
  tensor_curry (tensor_uncurry e ≫ g) =
  e ≫ (preadditive_yoneda.flip.obj (opposite.op B)).map g :=
begin
  ext a b,
  dsimp [tensor_curry, tensor_uncurry, preadditive_yoneda],
  simp,
end

@[simps]
def tensor_functor : AddCommGroup.{u} ⥤ AddCommGroup.{u} ⥤ AddCommGroup.{u} :=
{ obj := λ A,
  { obj := λ B, tensor A B,
    map := λ B B' f, map_tensor (𝟙 _) f,
    map_id' := λ A, map_tensor_id,
    map_comp' := λ A B C f g, map_tensor_comp_right _ _ },
  map := λ A A' f,
  { app := λ B, map_tensor f (𝟙 _),
    naturality' := λ B C g, begin
      dsimp,
      rw [← map_tensor_eq_comp, ← map_tensor_eq_comp'],
    end },
  map_id' := begin
    intros A,
    ext B : 2,
    dsimp, exact map_tensor_id,
  end,
  map_comp' := begin
    intros A B C f g,
    ext B : 2,
    dsimp, exact map_tensor_comp_left _ _,
  end }
.

open opposite

def tensor_adj (B : AddCommGroup.{u}) :
  tensor_functor.flip.obj B ⊣ preadditive_coyoneda.obj (op B) :=
adjunction.mk_of_hom_equiv
{ hom_equiv := λ A C, (tensor_curry_equiv A B C).to_equiv,
  hom_equiv_naturality_left_symm' := λ A A' C f g, begin
    apply tensor_ext, intros x y,
    erw [tensor_curry_equiv_symm_apply, comp_apply, tensor_curry_equiv_symm_apply],
    dsimp only [tensor_uncurry],
    simp only [linear_map.comp_apply, tensor_product.lift.tmul, tensor_product.map_tmul,
      add_monoid_hom.coe_to_int_linear_map, id_apply, comp_apply], refl,
  end,
  hom_equiv_naturality_right' := λ A C C' f g, by { ext x y : 2, refl } }
.

instance tensor_flip_preserves_colimits (B : AddCommGroup.{u}) :
  limits.preserves_colimits (tensor_functor.flip.obj B) :=
(tensor_adj B).left_adjoint_preserves_colimits

def tensor_explicit_pi_comparison {α : Type u} [fintype α] (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) :
  tensor (AddCommGroup.of (direct_sum α (λ i, X i))) B ⟶
  AddCommGroup.of (direct_sum α (λ i, tensor (X i) B)) :=
direct_sum_lift.{u u+1} _ $ λ a, map_tensor (direct_sum_π.{u u+1} _ _) (𝟙 _)

def tensor_pi_comparison {α : Type u} (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) :
  tensor (∏ X) B ⟶ ∏ (λ a, tensor (X a) B) :=
limits.pi.lift $ λ b, map_tensor (limits.pi.π _ _) (𝟙 _)

open_locale classical

def tensor_explicit_pi_iso {α : Type u}
  (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) :
  (of (direct_sum α (λ (i : α), ↥(X i)))).tensor B ≅
  of (direct_sum α (λ (i : α), ↥((X i).tensor B))) :=
{ hom := tensor_uncurry $ direct_sum_desc.{u u+1} X $ λ i, tensor_curry $
    direct_sum_ι.{u u+1} _ i,
  inv := direct_sum_desc.{u u+1} _ $ λ i,
    map_tensor (direct_sum_ι.{u u+1} X i) (𝟙 _),
  hom_inv_id' := begin
    apply (tensor_curry_equiv _ _ _).injective,
    ext a b,
    dsimp [tensor_curry, tensor_uncurry, direct_sum_desc],
    simp only [comp_apply, linear_map.to_add_monoid_hom_coe, tensor_product.lift.tmul,
      linear_map.coe_comp, add_monoid_hom.coe_to_int_linear_map, add_monoid_hom.coe_mk,
      direct_sum.to_add_monoid_of, id_apply],
    dsimp [direct_sum_ι],
    simp only [direct_sum.to_add_monoid_of],
    dsimp [map_tensor],
    simp only [id_apply],
  end,
  inv_hom_id' := begin
    apply direct_sum_hom_ext'.{u u+1},
    intros i,
    simp only [direct_sum_ι_desc_assoc, category.comp_id],
    apply (tensor_curry_equiv _ _ _).injective,
    ext a b k,
    dsimp [tensor_curry, direct_sum_ι, direct_sum.of, map_tensor,
      tensor_uncurry, tensor_curry, direct_sum_desc],
    simp only [comp_apply, linear_map.to_add_monoid_hom_coe, tensor_product.map_tmul,
      add_monoid_hom.coe_to_int_linear_map, dfinsupp.single_add_hom_apply, id_apply,
      tensor_product.lift.tmul, linear_map.coe_comp, add_monoid_hom.coe_mk,
      dfinsupp.single_apply],
    dsimp [direct_sum.to_add_monoid],
    simp only [dfinsupp.sum_add_hom_single, add_monoid_hom.coe_mk, dfinsupp.single_apply]
  end }

lemma tensor_explicit_pi_iso_hom_eq {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) :
  (tensor_explicit_pi_iso X B).hom = tensor_explicit_pi_comparison X B :=
begin
  symmetry,
  apply direct_sum_hom_ext.{u u+1}, swap, apply_instance,
  intros j,
  apply (tensor_curry_equiv _ _ _).injective,
  apply direct_sum_hom_ext'.{u u+1}, intros i,
  apply (tensor_curry_equiv _ _ _).symm.injective,
  dsimp,
  simp_rw tensor_uncurry_comp_curry,
  erw [direct_sum_lift_π, ← map_tensor_comp_comp, category.id_comp],
  dsimp only [tensor_explicit_pi_iso],
  erw [← category.assoc], let t := _, change _ = t ≫ _,
  have ht : t = direct_sum_ι.{u u+1} _ i,
  { dsimp [t],
    have := direct_sum_ι_desc.{u u+1} (λ i, tensor (X i) B)
      (λ i, map_tensor (direct_sum_ι.{u u+1} _ i) (𝟙 _)) i,
    dsimp at this, rw ← this, clear this,
    rw category.assoc,
    erw [(tensor_explicit_pi_iso X B).inv_hom_id, category.comp_id] },
  rw ht, clear ht, clear t,
  by_cases i = j,
  { subst h,
    simp [direct_sum_ι_π.{u u+1}] },
  { simp [direct_sum_ι_π_of_ne.{u u+1} _ _ _ h], }
end

instance is_iso_tensor_explicit_pi_comparison {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) : is_iso (tensor_explicit_pi_comparison X B) :=
begin
  rw ← tensor_explicit_pi_iso_hom_eq,
  apply_instance
end

lemma tensor_explicit_pi_comparison_comparison {α : Type u}
  [fintype α]
  (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) :
  tensor_pi_comparison X B =
  map_tensor (direct_sum_lift.{u u+1} _ $ limits.pi.π _) (𝟙 _) ≫
  tensor_explicit_pi_comparison X B ≫
  limits.pi.lift (direct_sum_π.{u u+1} (λ i, tensor (X i) B)) :=
begin
  ext1,
  dsimp [tensor_pi_comparison],
  simp only [limits.limit.lift_π, limits.fan.mk_π_app, category.assoc],
  dsimp [tensor_explicit_pi_comparison],
  rw [direct_sum_lift_π, ← map_tensor_comp_left, direct_sum_lift_π],
end

instance is_iso_tensor_pi_comparison {α : Type u} [fintype α]
  (X : α → AddCommGroup.{u+1})
  (B : AddCommGroup.{u+1}) : is_iso (tensor_pi_comparison X B) :=
begin
  rw tensor_explicit_pi_comparison_comparison,
  apply_with is_iso.comp_is_iso { instances := ff },
  { change is_iso ((tensor_functor.flip.obj B).map _),
    apply_with functor.map_is_iso { instances := ff },
    change is_iso ((limits.limit.is_limit _).cone_point_unique_up_to_iso
      (is_limit_direct_sum_fan.{u u+1} X)).hom,
    apply_instance },
  apply_with is_iso.comp_is_iso { instances := ff }, apply_instance,
  change is_iso ((is_limit_direct_sum_fan.{u u+1} _).cone_point_unique_up_to_iso
    (limits.limit.is_limit _)).hom,
  apply_instance,
  apply_instance
end

def tensor_flip (A B : AddCommGroup.{u}) : A.tensor B ≅ B.tensor A :=
linear_equiv_to_iso (tensor_product.comm _ _ _)

def tensor_functor_iso_flip :
  tensor_functor.flip ≅ tensor_functor :=
nat_iso.of_components (λ A,
  nat_iso.of_components (λ B, tensor_flip _ _) begin
    intros U B f, apply tensor_ext, intros a b, refl,
  end) begin
    intros U V f, ext A : 2, apply tensor_ext, intros a b,
    refl,
  end

instance preserves_colimits_tensor_obj (A : AddCommGroup.{u}) :
  limits.preserves_colimits (tensor_functor.obj A) :=
limits.preserves_colimits_of_nat_iso (tensor_functor_iso_flip.app _)

section preserves_finite_limits

variables {X Y : AddCommGroup.{u}} (f : X ⟶ Y) [mono f]
  (A : AddCommGroup.{u})

def tensor_unit_iso_aux (t A : AddCommGroup.{u}) (ht : is_tensor_unit t) :
  t.tensor A ⟶ A :=
tensor_uncurry $ ht.as_hom (𝟙 _)

instance is_iso_tensor_unit_iso_aux (t A : AddCommGroup.{u}) (ht : is_tensor_unit t) :
  is_iso (tensor_unit_iso_aux t A ht) :=
begin
  let q : A ⟶ t.tensor A := ⟨λ a, ht.gen ⊗ₜ a, _ ,_⟩,
  use q, split,
  { apply_fun (tensor_curry_equiv _ _ _).to_equiv,
    dsimp [tensor_unit_iso_aux], rw tensor_curry_uncurry_comp, apply ht.ext,
    simp, dsimp [tensor_curry], simp },
  { ext, dsimp [q, tensor_unit_iso_aux, tensor_uncurry], simp, },
  { simp, },
  { intros x y, rw tensor_product.tmul_add },
end

def tensor_unit_iso (t A : AddCommGroup.{u}) (ht : is_tensor_unit t) :
  t.tensor A ≅ A :=
as_iso (tensor_unit_iso_aux t A ht)

lemma tensor_unit_iso_naturality (t A B : AddCommGroup.{u}) (ht : is_tensor_unit t) (f : A ⟶ B) :
  (tensor_unit_iso t A ht).hom ≫ f = map_tensor (𝟙 _) f ≫ (tensor_unit_iso t B ht).hom :=
begin
  apply_fun (tensor_curry_equiv _ _ _).to_equiv,
  dsimp [tensor_unit_iso, tensor_unit_iso_aux],
  rw tensor_curry_uncurry_comp,
  apply ht.ext,
  simp, dsimp, simp,
  ext, dsimp [tensor_curry, map_tensor, tensor_uncurry],
  simp,
end

instance tensor_obj_map_preserves_mono [no_zero_smul_divisors ℤ A] :
  mono ((tensor_functor.obj A).map f) :=
begin
  let D := A.diagram,
  let T := A.cocone,
  let hT : limits.is_colimit T := A.is_colimit_cocone,
  let FX : A.index_cat ⥤ AddCommGroup :=
    D ⋙ tensor_functor.flip.obj X,
  let FY : A.index_cat ⥤ AddCommGroup :=
    D ⋙ tensor_functor.flip.obj Y,
  let η : FX ⟶ FY := whisker_left _ (tensor_functor.flip.map f),
  let eX : tensor A X ≅ limits.colimit FX :=
    (limits.is_colimit_of_preserves
    (tensor_functor.flip.obj X) hT).cocone_point_unique_up_to_iso
    (limits.colimit.is_colimit _),
  let eY : tensor A Y ≅ limits.colimit FY :=
    (limits.is_colimit_of_preserves
    (tensor_functor.flip.obj Y) hT).cocone_point_unique_up_to_iso
    (limits.colimit.is_colimit _),
  let t := _, change mono t,
  have ht : t = eX.hom ≫ limits.colim_map η ≫ eY.inv,
  { dsimp [t, eX, eY],
    apply (limits.is_colimit_of_preserves (tensor_functor.flip.obj X) hT).hom_ext,
    intros i,
    erw (limits.is_colimit_of_preserves (tensor_functor.flip.obj X) hT).fac_assoc,
    simp only [functor.map_cocone_ι_app, functor.flip_obj_map,
      tensor_functor_map_app, limits.colimit.cocone_ι,
      limits.ι_colim_map_assoc, whisker_left_app, functor.flip_map_app,
      tensor_functor_obj_map, limits.colimit.comp_cocone_point_unique_up_to_iso_inv],
    simp only [← map_tensor_comp_comp, category.id_comp, category.comp_id],
    dsimp, erw category.comp_id },
  rw ht, clear ht t,
  suffices : mono (limits.colim_map η),
  { resetI, apply_instance },
  suffices : ∀ i, mono (η.app i),
  { resetI, apply mono_colim_map_of_mono },
  intros i,
  obtain ⟨α : Type u, _, e, -⟩ := exists_sigma_iso_of_index _ i, resetI,
  change mono ((tensor_functor.obj (of i.val)).map f),
  clear eX eY,
  let eX : ((tensor_functor.obj (of i.val)).obj X) ≅
    (tensor_functor.obj (∐ λ (i : α), tunit)).obj X := (tensor_functor.map_iso e.symm).app X,
  let eY : ((tensor_functor.obj (of i.val)).obj Y) ≅
    (tensor_functor.obj (∐ λ (i : α), tunit)).obj Y := (tensor_functor.map_iso e.symm).app Y,
  have : (tensor_functor.obj (of ↥(i.val))).map f =
    eX.hom ≫ (tensor_functor.obj _).map f ≫ eY.inv,
  { dsimp [eX, eY],
    simpa only [← map_tensor_comp_comp, category.id_comp, category.comp_id, e.inv_hom_id] },
  rw this, clear this,
  suffices : mono ((tensor_functor.obj (∐ λ (i : α), tunit)).map f), { resetI, apply_instance },
  clear eX eY e i η FX FY D,
  let eX : (tensor_functor.obj (∐ λ (i : α), tunit)).obj X ≅
    (∐ (λ i : α, tensor tunit X)) :=
    preserves_colimit_iso (tensor_functor.flip.obj X) _ ≪≫
    limits.has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ _, iso.refl _),
  let eY : (tensor_functor.obj (∐ λ (i : α), tunit)).obj Y ≅
    (∐ (λ i : α, tensor tunit Y)) :=
    preserves_colimit_iso (tensor_functor.flip.obj Y) _ ≪≫
    limits.has_colimit.iso_of_nat_iso (discrete.nat_iso $ λ _, iso.refl _),
  have : (tensor_functor.obj (∐ λ (i : α), tunit)).map f =
    eX.hom ≫ _ ≫ eY.inv,
  rotate 2,
  { apply limits.sigma.desc,
    intros i, refine _ ≫ limits.sigma.ι _ i,
    exact map_tensor (𝟙 _) f },
  { dsimp [eX, eY],
    apply (limits.is_colimit_of_preserves (tensor_functor.flip.obj X) _).hom_ext,
    rotate,
    { apply limits.colimit.is_colimit },
    { apply_instance },
    rintro ⟨j⟩,
    slice_rhs 1 2
    { erw (limits.is_colimit_of_preserves (tensor_functor.flip.obj X)
      (limits.colimit.is_colimit _)).fac },
    dsimp,
    simp only [limits.has_colimit.iso_of_nat_iso_ι_hom, discrete.nat_iso_hom_app,
      category.assoc, limits.colimit.ι_desc, limits.cofan.mk_ι_app,
      limits.has_colimit.iso_of_nat_iso_ι_inv, discrete.nat_iso_inv_app,
      ι_preserves_colimits_iso_inv, functor.flip_obj_map, tensor_functor_map_app],
    dsimp, simp only [category.id_comp, ← map_tensor_comp_comp, category.comp_id], },
  rw this, clear this,
  let t := _, change mono (eX.hom ≫ t ≫ eY.inv),
  suffices : mono t, { resetI, apply_instance },
  suffices : mono (map_tensor (𝟙 tunit) f),
  { apply AB4.cond, intros i, assumption },
  clear eX eY,
  let eX : tunit.tensor X ≅ X := tensor_unit_iso _ _ is_tensor_unit_tunit,
  let eY : tunit.tensor Y ≅ Y := tensor_unit_iso _ _ is_tensor_unit_tunit,
  have : map_tensor (𝟙 tunit) f = eX.hom ≫ f ≫ eY.inv,
  { simp [reassoc_of (tensor_unit_iso_naturality tunit X Y is_tensor_unit_tunit f)] },
  rw this, apply_instance,
end

end preserves_finite_limits

instance tensor_functor_additive (A : AddCommGroup.{u}) :
  (tensor_functor.obj A).additive := { }

instance tensor_functor_flip_additive (A : AddCommGroup.{u}) :
  (tensor_functor.flip.obj A).additive := { }

end AddCommGroup