/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.comma
import Mathlib.category_theory.groupoid
import Mathlib.category_theory.punit
import Mathlib.PostPort

universes w v u

namespace Mathlib

/-!
# The category of elements

This file defines the category of elements, also known as (a special case of) the Grothendieck construction.

Given a functor `F : C ⥤ Type`, an object of `F.elements` is a pair `(X : C, x : F.obj X)`.
A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.

## Implementation notes
This construction is equivalent to a special case of a comma construction, so this is mostly just
a more convenient API. We prove the equivalence in `category_theory.category_of_elements.comma_equivalence`.

## References
* [Emily Riehl, *Category Theory in Context*, Section 2.4][riehl2017]
* <https://en.wikipedia.org/wiki/Category_of_elements>
* <https://ncatlab.org/nlab/show/category+of+elements>

## Tags
category of elements, Grothendieck construction, comma category
-/

namespace category_theory

/--
The type of objects for the category of elements of a functor `F : C ⥤ Type`
is a pair `(X : C, x : F.obj X)`.
-/
def functor.elements {C : Type u} [category C] (F : C ⥤ Type w) :=
  sigma fun (c : C) => functor.obj F c

/-- The category structure on `F.elements`, for `F : C ⥤ Type`.
    A morphism `(X, x) ⟶ (Y, y)` is a morphism `f : X ⟶ Y` in `C`, so `F.map f` takes `x` to `y`.
 -/
protected instance category_of_elements {C : Type u} [category C] (F : C ⥤ Type w) : category (functor.elements F) :=
  category.mk

namespace category_of_elements

theorem ext {C : Type u} [category C] (F : C ⥤ Type w) {x : functor.elements F} {y : functor.elements F} (f : x ⟶ y) (g : x ⟶ y) (w : subtype.val f = subtype.val g) : f = g :=
  subtype.ext_val w

@[simp] theorem comp_val {C : Type u} [category C] {F : C ⥤ Type w} {p : functor.elements F} {q : functor.elements F} {r : functor.elements F} {f : p ⟶ q} {g : q ⟶ r} : subtype.val (f ≫ g) = subtype.val f ≫ subtype.val g :=
  rfl

@[simp] theorem id_val {C : Type u} [category C] {F : C ⥤ Type w} {p : functor.elements F} : subtype.val 𝟙 = 𝟙 :=
  rfl

end category_of_elements

protected instance groupoid_of_elements {G : Type u} [groupoid G] (F : G ⥤ Type w) : groupoid (functor.elements F) :=
  groupoid.mk fun (p q : functor.elements F) (f : p ⟶ q) => { val := inv (subtype.val f), property := sorry }

namespace category_of_elements

/-- The functor out of the category of elements which forgets the element. -/
@[simp] theorem π_map {C : Type u} [category C] (F : C ⥤ Type w) (X : functor.elements F) (Y : functor.elements F) (f : X ⟶ Y) : functor.map (π F) f = subtype.val f :=
  Eq.refl (functor.map (π F) f)

/--
A natural transformation between functors induces a functor between the categories of elements.
-/
@[simp] theorem map_obj_fst {C : Type u} [category C] {F₁ : C ⥤ Type w} {F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) (t : functor.elements F₁) : sigma.fst (functor.obj (map α) t) = sigma.fst t :=
  Eq.refl (sigma.fst (functor.obj (map α) t))

@[simp] theorem map_π {C : Type u} [category C] {F₁ : C ⥤ Type w} {F₂ : C ⥤ Type w} (α : F₁ ⟶ F₂) : map α ⋙ π F₂ = π F₁ :=
  rfl

/-- The forward direction of the equivalence `F.elements ≅ (*, F)`. -/
def to_comma {C : Type u} [category C] (F : C ⥤ Type w) : functor.elements F ⥤ comma (functor.from_punit PUnit) F :=
  functor.mk
    (fun (X : functor.elements F) => comma.mk fun (_x : functor.obj (functor.from_punit PUnit) PUnit.unit) => sigma.snd X)
    fun (X Y : functor.elements F) (f : X ⟶ Y) => comma_morphism.mk

@[simp] theorem to_comma_obj {C : Type u} [category C] (F : C ⥤ Type w) (X : functor.elements F) : functor.obj (to_comma F) X = comma.mk fun (_x : functor.obj (functor.from_punit PUnit) PUnit.unit) => sigma.snd X :=
  rfl

@[simp] theorem to_comma_map {C : Type u} [category C] (F : C ⥤ Type w) {X : functor.elements F} {Y : functor.elements F} (f : X ⟶ Y) : functor.map (to_comma F) f = comma_morphism.mk :=
  rfl

/-- The reverse direction of the equivalence `F.elements ≅ (*, F)`. -/
def from_comma {C : Type u} [category C] (F : C ⥤ Type w) : comma (functor.from_punit PUnit) F ⥤ functor.elements F :=
  functor.mk (fun (X : comma (functor.from_punit PUnit) F) => sigma.mk (comma.right X) (comma.hom X PUnit.unit))
    fun (X Y : comma (functor.from_punit PUnit) F) (f : X ⟶ Y) => { val := comma_morphism.right f, property := sorry }

@[simp] theorem from_comma_obj {C : Type u} [category C] (F : C ⥤ Type w) (X : comma (functor.from_punit PUnit) F) : functor.obj (from_comma F) X = sigma.mk (comma.right X) (comma.hom X PUnit.unit) :=
  rfl

@[simp] theorem from_comma_map {C : Type u} [category C] (F : C ⥤ Type w) {X : comma (functor.from_punit PUnit) F} {Y : comma (functor.from_punit PUnit) F} (f : X ⟶ Y) : functor.map (from_comma F) f =
  { val := comma_morphism.right f, property := congr_fun (Eq.symm (comma_morphism.w' f)) PUnit.unit } :=
  rfl

/-- The equivalence between the category of elements `F.elements`
    and the comma category `(*, F)`. -/
def comma_equivalence {C : Type u} [category C] (F : C ⥤ Type w) : functor.elements F ≌ comma (functor.from_punit PUnit) F :=
  equivalence.mk (to_comma F) (from_comma F)
    (nat_iso.of_components (fun (X : functor.elements F) => eq_to_iso sorry) sorry)
    (nat_iso.of_components (fun (X : comma (functor.from_punit PUnit) F) => iso.mk comma_morphism.mk comma_morphism.mk)
      sorry)

@[simp] theorem comma_equivalence_functor {C : Type u} [category C] (F : C ⥤ Type w) : equivalence.functor (comma_equivalence F) = to_comma F :=
  rfl

@[simp] theorem comma_equivalence_inverse {C : Type u} [category C] (F : C ⥤ Type w) : equivalence.inverse (comma_equivalence F) = from_comma F :=
  rfl


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Kenny Lau, Johan Commelin, Mario Carneiro, Kevin Buzzard
-/
import group_theory.submonoid.basic
import algebra.big_operators.basic
import deprecated.group

/-!
# Unbundled submonoids (deprecated)

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

This file is deprecated, and is no longer imported by anything in mathlib other than other
deprecated files, and test files. You should not need to import it.

This file defines unbundled multiplicative and additive submonoids. Instead of using this file,
please use `submonoid G` and `add_submonoid A`, defined in `group_theory.submonoid.basic`.

## Main definitions

`is_add_submonoid (S : set M)` : the predicate that `S` is the underlying subset of an additive
submonoid of `M`. The bundled variant `add_submonoid M` should be used in preference to this.

`is_submonoid (S : set M)` : the predicate that `S` is the underlying subset of a submonoid
of `M`. The bundled variant `submonoid M` should be used in preference to this.

## Tags
submonoid, submonoids, is_submonoid
-/

open_locale big_operators

variables {M : Type*} [monoid M] {s : set M}
variables {A : Type*} [add_monoid A] {t : set A}

/-- `s` is an additive submonoid: a set containing 0 and closed under addition.
Note that this structure is deprecated, and the bundled variant `add_submonoid A` should be
preferred. -/
structure is_add_submonoid (s : set A) : Prop :=
(zero_mem : (0:A) ∈ s)
(add_mem {a b} : a ∈ s → b ∈ s → a + b ∈ s)

/-- `s` is a submonoid: a set containing 1 and closed under multiplication.
Note that this structure is deprecated, and the bundled variant `submonoid M` should be
preferred. -/
@[to_additive]
structure is_submonoid (s : set M) : Prop :=
(one_mem : (1:M) ∈ s)
(mul_mem {a b} : a ∈ s → b ∈ s → a * b ∈ s)

lemma additive.is_add_submonoid
  {s : set M} : ∀ (is : is_submonoid s), @is_add_submonoid (additive M) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem additive.is_add_submonoid_iff
  {s : set M} : @is_add_submonoid (additive M) _ s ↔ is_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, additive.is_add_submonoid⟩

lemma multiplicative.is_submonoid
  {s : set A} : ∀ (is : is_add_submonoid s), @is_submonoid (multiplicative A) _ s
| ⟨h₁, h₂⟩ := ⟨h₁, @h₂⟩

theorem multiplicative.is_submonoid_iff
  {s : set A} : @is_submonoid (multiplicative A) _ s ↔ is_add_submonoid s :=
⟨λ ⟨h₁, h₂⟩, ⟨h₁, @h₂⟩, multiplicative.is_submonoid⟩

/-- The intersection of two submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of two `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of M."]
lemma is_submonoid.inter {s₁ s₂ : set M} (is₁ : is_submonoid s₁) (is₂ : is_submonoid s₂) :
  is_submonoid (s₁ ∩ s₂) :=
{ one_mem := ⟨is₁.one_mem, is₂.one_mem⟩,
  mul_mem := λ x y hx hy,
    ⟨is₁.mul_mem hx.1 hy.1, is₂.mul_mem hx.2 hy.2⟩ }

/-- The intersection of an indexed set of submonoids of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The intersection of an indexed set of `add_submonoid`s of an `add_monoid` `M` is
an `add_submonoid` of `M`."]
lemma is_submonoid.Inter {ι : Sort*} {s : ι → set M} (h : ∀ y : ι, is_submonoid (s y)) :
  is_submonoid (set.Inter s) :=
{ one_mem := set.mem_Inter.2 $ λ y, (h y).one_mem,
  mul_mem := λ x₁ x₂ h₁ h₂, set.mem_Inter.2 $
    λ y, (h y).mul_mem (set.mem_Inter.1 h₁ y) (set.mem_Inter.1 h₂ y) }

/-- The union of an indexed, directed, nonempty set of submonoids of a monoid `M` is a submonoid
    of `M`. -/
@[to_additive "The union of an indexed, directed, nonempty set
of `add_submonoid`s of an `add_monoid` `M` is an `add_submonoid` of `M`. "]
lemma is_submonoid_Union_of_directed {ι : Type*} [hι : nonempty ι]
  {s : ι → set M} (hs : ∀ i, is_submonoid (s i))
  (directed : ∀ i j, ∃ k, s i ⊆ s k ∧ s j ⊆ s k) :
  is_submonoid (⋃i, s i) :=
{ one_mem := let ⟨i⟩ := hι in set.mem_Union.2 ⟨i, (hs i).one_mem⟩,
  mul_mem := λ a b ha hb,
    let ⟨i, hi⟩ := set.mem_Union.1 ha in
    let ⟨j, hj⟩ := set.mem_Union.1 hb in
    let ⟨k, hk⟩ := directed i j in
    set.mem_Union.2 ⟨k, (hs k).mul_mem (hk.1 hi) (hk.2 hj)⟩ }

section powers

/-- The set of natural number powers `1, x, x², ...` of an element `x` of a monoid. -/
@[to_additive multiples
"The set of natural number multiples `0, x, 2x, ...` of an element `x` of an `add_monoid`."]
def powers (x : M) : set M := {y | ∃ n:ℕ, x^n = y}

/-- 1 is in the set of natural number powers of an element of a monoid. -/
@[to_additive "0 is in the set of natural number multiples of an element of an `add_monoid`."]
lemma powers.one_mem {x : M} : (1 : M) ∈ powers x := ⟨0, pow_zero _⟩

/-- An element of a monoid is in the set of that element's natural number powers. -/
@[to_additive
"An element of an `add_monoid` is in the set of that element's natural number multiples."]
lemma powers.self_mem {x : M} : x ∈ powers x := ⟨1, pow_one _⟩

/-- The set of natural number powers of an element of a monoid is closed under multiplication. -/
@[to_additive
"The set of natural number multiples of an element of an `add_monoid` is closed under addition."]
lemma powers.mul_mem {x y z : M} : (y ∈ powers x) → (z ∈ powers x) → (y * z ∈ powers x) :=
λ ⟨n₁, h₁⟩ ⟨n₂, h₂⟩, ⟨n₁ + n₂, by simp only [pow_add, *]⟩

/-- The set of natural number powers of an element of a monoid `M` is a submonoid of `M`. -/
@[to_additive "The set of natural number multiples of an element of
an `add_monoid` `M` is an `add_submonoid` of `M`."]
lemma powers.is_submonoid (x : M) : is_submonoid (powers x) :=
{ one_mem := powers.one_mem,
  mul_mem := λ y z, powers.mul_mem }

/-- A monoid is a submonoid of itself. -/
@[to_additive "An `add_monoid` is an `add_submonoid` of itself."]
lemma univ.is_submonoid : is_submonoid (@set.univ M) := by split; simp

/-- The preimage of a submonoid under a monoid hom is a submonoid of the domain. -/
@[to_additive "The preimage of an `add_submonoid` under an `add_monoid` hom is
an `add_submonoid` of the domain."]
lemma is_submonoid.preimage {N : Type*} [monoid N] {f : M → N} (hf : is_monoid_hom f)
  {s : set N} (hs : is_submonoid s) : is_submonoid (f ⁻¹' s) :=
{ one_mem := show f 1 ∈ s, by rw is_monoid_hom.map_one hf; exact hs.one_mem,
  mul_mem := λ a b (ha : f a ∈ s) (hb : f b ∈ s),
    show f (a * b) ∈ s, by rw is_monoid_hom.map_mul hf; exact hs.mul_mem ha hb }

/-- The image of a submonoid under a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_submonoid` under an `add_monoid`
hom is an `add_submonoid` of the codomain."]
lemma is_submonoid.image {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f)
  {s : set M} (hs : is_submonoid s) : is_submonoid (f '' s) :=
{ one_mem := ⟨1, hs.one_mem, hf.map_one⟩,
  mul_mem := λ a b ⟨x, hx⟩ ⟨y, hy⟩, ⟨x * y, hs.mul_mem hx.1 hy.1,
    by rw [hf.map_mul, hx.2, hy.2]⟩ }

/-- The image of a monoid hom is a submonoid of the codomain. -/
@[to_additive "The image of an `add_monoid` hom is an `add_submonoid`
of the codomain."]
lemma range.is_submonoid {γ : Type*} [monoid γ] {f : M → γ} (hf : is_monoid_hom f) :
  is_submonoid (set.range f) :=
by { rw ← set.image_univ, exact univ.is_submonoid.image hf }

/-- Submonoids are closed under natural powers. -/
@[to_additive is_add_submonoid.smul_mem
"An `add_submonoid` is closed under multiplication by naturals."]
lemma is_submonoid.pow_mem {a : M} (hs : is_submonoid s) (h : a ∈ s) : ∀ {n : ℕ}, a ^ n ∈ s
| 0 := by { rw pow_zero, exact hs.one_mem }
| (n + 1) := by { rw pow_succ, exact hs.mul_mem h is_submonoid.pow_mem }

/-- The set of natural number powers of an element of a submonoid is a subset of the submonoid. -/
@[to_additive is_add_submonoid.multiples_subset "The set of natural number multiples of an element
of an `add_submonoid` is a subset of the `add_submonoid`."]
lemma is_submonoid.power_subset {a : M} (hs : is_submonoid s) (h : a ∈ s) : powers a ⊆ s :=
assume x ⟨n, hx⟩, hx ▸ hs.pow_mem h

end powers

namespace is_submonoid

/-- The product of a list of elements of a submonoid is an element of the submonoid. -/
@[to_additive "The sum of a list of elements of an `add_submonoid` is an element of the
`add_submonoid`."]
lemma list_prod_mem (hs : is_submonoid s) : ∀{l : list M}, (∀x∈l, x ∈ s) → l.prod ∈ s
| []     h := hs.one_mem
| (a::l) h :=
  suffices a * l.prod ∈ s, by simpa,
  have a ∈ s ∧ (∀x∈l, x ∈ s), by simpa using h,
  hs.mul_mem this.1 (list_prod_mem this.2)

/-- The product of a multiset of elements of a submonoid of a `comm_monoid` is an element of
the submonoid. -/
@[to_additive "The sum of a multiset of elements of an `add_submonoid` of an `add_comm_monoid`
is an element of the `add_submonoid`. "]
lemma multiset_prod_mem {M} [comm_monoid M] {s : set M} (hs : is_submonoid s) (m : multiset M) :
  (∀a∈m, a ∈ s) → m.prod ∈ s :=
begin
  refine quotient.induction_on m (assume l hl, _),
  rw [multiset.quot_mk_to_coe, multiset.coe_prod],
  exact list_prod_mem hs hl
end

/-- The product of elements of a submonoid of a `comm_monoid` indexed by a `finset` is an element
of the submonoid. -/
@[to_additive "The sum of elements of an `add_submonoid` of an `add_comm_monoid` indexed by
a `finset` is an element of the `add_submonoid`."]
lemma finset_prod_mem {M A} [comm_monoid M] {s : set M} (hs : is_submonoid s) (f : A → M) :
  ∀(t : finset A), (∀b∈t, f b ∈ s) → ∏ b in t, f b ∈ s
| ⟨m, hm⟩ _ := multiset_prod_mem hs _ (by simpa)

end is_submonoid

namespace add_monoid

/-- The inductively defined membership predicate for the submonoid generated by a subset of a
    monoid. -/
inductive in_closure (s : set A) : A → Prop
| basic {a : A} : a ∈ s → in_closure a
| zero : in_closure 0
| add {a b : A} : in_closure a → in_closure b → in_closure (a + b)

end add_monoid

namespace monoid

/-- The inductively defined membership predicate for the `submonoid` generated by a subset of an
    monoid. -/
@[to_additive]
inductive in_closure (s : set M) : M → Prop
| basic {a : M} : a ∈ s → in_closure a
| one : in_closure 1
| mul {a b : M} : in_closure a → in_closure b → in_closure (a * b)

/-- The inductively defined submonoid generated by a subset of a monoid. -/
@[to_additive "The inductively defined `add_submonoid` genrated by a subset of an `add_monoid`."]
def closure (s : set M) : set M := {a | in_closure s a }

@[to_additive]
lemma closure.is_submonoid (s : set M) : is_submonoid (closure s) :=
{ one_mem := in_closure.one, mul_mem := assume a b, in_closure.mul }

/-- A subset of a monoid is contained in the submonoid it generates. -/
@[to_additive "A subset of an `add_monoid` is contained in the `add_submonoid` it generates."]
theorem subset_closure {s : set M} : s ⊆ closure s :=
assume a, in_closure.basic

/-- The submonoid generated by a set is contained in any submonoid that contains the set. -/
@[to_additive "The `add_submonoid` generated by a set is contained in any `add_submonoid` that
contains the set."]
theorem closure_subset {s t : set M} (ht : is_submonoid t) (h : s ⊆ t) : closure s ⊆ t :=
assume a ha, by induction ha; simp [h _, *, is_submonoid.one_mem, is_submonoid.mul_mem]

/-- Given subsets `t` and `s` of a monoid `M`, if `s ⊆ t`, the submonoid of `M` generated by `s` is
    contained in the submonoid generated by `t`. -/
@[to_additive "Given subsets `t` and `s` of an `add_monoid M`, if `s ⊆ t`, the `add_submonoid`
of `M` generated by `s` is contained in the `add_submonoid` generated by `t`."]
theorem closure_mono {s t : set M} (h : s ⊆ t) : closure s ⊆ closure t :=
closure_subset (closure.is_submonoid t) $ set.subset.trans h subset_closure

/-- The submonoid generated by an element of a monoid equals the set of natural number powers of
    the element. -/
@[to_additive "The `add_submonoid` generated by an element of an `add_monoid` equals the set of
natural number multiples of the element."]
theorem closure_singleton {x : M} : closure ({x} : set M) = powers x :=
set.eq_of_subset_of_subset (closure_subset (powers.is_submonoid x) $ set.singleton_subset_iff.2 $
  powers.self_mem) $ is_submonoid.power_subset (closure.is_submonoid _) $
  set.singleton_subset_iff.1 $ subset_closure

/-- The image under a monoid hom of the submonoid generated by a set equals the submonoid generated
    by the image of the set under the monoid hom. -/
@[to_additive "The image under an `add_monoid` hom of the `add_submonoid` generated by a set equals
the `add_submonoid` generated by the image of the set under the `add_monoid` hom."]
lemma image_closure {A : Type*} [monoid A] {f : M → A} (hf : is_monoid_hom f) (s : set M) :
  f '' closure s = closure (f '' s) :=
le_antisymm
  begin
    rintros _ ⟨x, hx, rfl⟩,
    apply in_closure.rec_on hx; intros,
    { solve_by_elim [subset_closure, set.mem_image_of_mem] },
    { rw [hf.map_one], apply is_submonoid.one_mem (closure.is_submonoid (f '' s))},
    { rw [hf.map_mul], solve_by_elim [(closure.is_submonoid _).mul_mem] }
  end
  (closure_subset (is_submonoid.image hf (closure.is_submonoid _)) $
    set.image_subset _ subset_closure)

/-- Given an element `a` of the submonoid of a monoid `M` generated by a set `s`, there exists
a list of elements of `s` whose product is `a`. -/
@[to_additive "Given an element `a` of the `add_submonoid` of an `add_monoid M` generated by
a set `s`, there exists a list of elements of `s` whose sum is `a`."]
theorem exists_list_of_mem_closure {s : set M} {a : M} (h : a ∈ closure s) :
  (∃l:list M, (∀x∈l, x ∈ s) ∧ l.prod = a) :=
begin
  induction h,
  case in_closure.basic : a ha { existsi ([a]), simp [ha] },
  case in_closure.one { existsi ([]), simp },
  case in_closure.mul : a b _ _ ha hb
  { rcases ha with ⟨la, ha, eqa⟩,
    rcases hb with ⟨lb, hb, eqb⟩,
    existsi (la ++ lb),
    simp [eqa.symm, eqb.symm, or_imp_distrib],
    exact assume a, ⟨ha a, hb a⟩ }
end

/-- Given sets `s, t` of a commutative monoid `M`, `x ∈ M` is in the submonoid of `M` generated by
    `s ∪ t` iff there exists an element of the submonoid generated by `s` and an element of the
    submonoid generated by `t` whose product is `x`. -/
@[to_additive "Given sets `s, t` of a commutative `add_monoid M`, `x ∈ M` is in the `add_submonoid`
of `M` generated by `s ∪ t` iff there exists an element of the `add_submonoid` generated by `s`
and an element of the `add_submonoid` generated by `t` whose sum is `x`."]
theorem mem_closure_union_iff {M : Type*} [comm_monoid M] {s t : set M} {x : M} :
  x ∈ closure (s ∪ t) ↔ ∃ y ∈ closure s, ∃ z ∈ closure t, y * z = x :=
⟨λ hx, let ⟨L, HL1, HL2⟩ := exists_list_of_mem_closure hx in HL2 ▸
  list.rec_on L (λ _, ⟨1, (closure.is_submonoid _).one_mem, 1,
    (closure.is_submonoid _).one_mem, mul_one _⟩)
    (λ hd tl ih HL1, let ⟨y, hy, z, hz, hyzx⟩ := ih (list.forall_mem_of_forall_mem_cons HL1) in
      or.cases_on (HL1 hd $ list.mem_cons_self _ _)
        (λ hs, ⟨hd * y, (closure.is_submonoid _).mul_mem (subset_closure hs) hy, z, hz,
          by rw [mul_assoc, list.prod_cons, ← hyzx]; refl⟩)
        (λ ht, ⟨y, hy, z * hd, (closure.is_submonoid _).mul_mem hz (subset_closure ht),
          by rw [← mul_assoc, list.prod_cons, ← hyzx, mul_comm hd]; refl⟩)) HL1,
λ ⟨y, hy, z, hz, hyzx⟩, hyzx ▸ (closure.is_submonoid _).mul_mem
  (closure_mono (set.subset_union_left _ _) hy)
  (closure_mono (set.subset_union_right _ _) hz)⟩

end monoid

/-- Create a bundled submonoid from a set `s` and `[is_submonoid s]`. -/
@[to_additive "Create a bundled additive submonoid from a set `s` and `[is_add_submonoid s]`."]
def submonoid.of {s : set M} (h : is_submonoid s) : submonoid M := ⟨s, λ _ _, h.2, h.1⟩

@[to_additive]
lemma submonoid.is_submonoid (S : submonoid M) : is_submonoid (S : set M) := ⟨S.3, λ _ _, S.2⟩


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.types
import Mathlib.category_theory.epi_mono
import Mathlib.PostPort

universes w v u l u_1 u_2 v' u_3

namespace Mathlib

/-!
# Concrete categories

A concrete category is a category `C` with a fixed faithful functor
`forget : C ⥤ Type*`.  We define concrete categories using `class
concrete_category`.  In particular, we impose no restrictions on the
carrier type `C`, so `Type` is a concrete category with the identity
forgetful functor.

Each concrete category `C` comes with a canonical faithful functor
`forget C : C ⥤ Type*`.  We say that a concrete category `C` admits a
*forgetful functor* to a concrete category `D`, if it has a functor
`forget₂ C D : C ⥤ D` such that `(forget₂ C D) ⋙ (forget D) = forget C`,
see `class has_forget₂`.  Due to `faithful.div_comp`, it suffices
to verify that `forget₂.obj` and `forget₂.map` agree with the equality
above; then `forget₂` will satisfy the functor laws automatically, see
`has_forget₂.mk'`.

Two classes helping construct concrete categories in the two most
common cases are provided in the files `bundled_hom` and
`unbundled_hom`, see their documentation for details.

## References

See [Ahrens and Lumsdaine, *Displayed Categories*][ahrens2017] for
related work.
-/

namespace category_theory

/--
A concrete category is a category `C` with a fixed faithful functor `forget : C ⥤ Type`.

Note that `concrete_category` potentially depends on three independent universe levels,
* the universe level `w` appearing in `forget : C ⥤ Type w`
* the universe level `v` of the morphisms (i.e. we have a `category.{v} C`)
* the universe level `u` of the objects (i.e `C : Type u`)
They are specified that order, to avoid unnecessary universe annotations.
-/
class concrete_category (C : Type u) [category C] where
  forget : C ⥤ Type w
  forget_faithful : faithful forget

/-- The forgetful functor from a concrete category to `Type u`. -/
def forget (C : Type v) [category C] [concrete_category C] : C ⥤ Type u :=
  concrete_category.forget C

/--
Provide a coercion to `Type u` for a concrete category. This is not marked as an instance
as it could potentially apply to every type, and so is too expensive in typeclass search.

You can use it on particular examples as:
```
instance : has_coe_to_sort X := concrete_category.has_coe_to_sort X
```
-/
def concrete_category.has_coe_to_sort (C : Type v) [category C] [concrete_category C] :
    has_coe_to_sort C :=
  has_coe_to_sort.mk (Type u) (functor.obj (concrete_category.forget C))

@[simp] theorem forget_obj_eq_coe {C : Type v} [category C] [concrete_category C] {X : C} :
    functor.obj (forget C) X = ↥X :=
  rfl

/-- Usually a bundled hom structure already has a coercion to function
that works with different universes. So we don't use this as a global instance. -/
def concrete_category.has_coe_to_fun {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} : has_coe_to_fun (X ⟶ Y) :=
  has_coe_to_fun.mk (fun (f : X ⟶ Y) => ↥X → ↥Y) fun (f : X ⟶ Y) => functor.map (forget C) f

/-- In any concrete category, we can test equality of morphisms by pointwise evaluations.-/
theorem concrete_category.hom_ext {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ⟶ Y) (g : X ⟶ Y) (w : ∀ (x : ↥X), coe_fn f x = coe_fn g x) : f = g :=
  faithful.map_injective (forget C) (funext fun (x : functor.obj (forget C) X) => w x)

@[simp] theorem forget_map_eq_coe {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ⟶ Y) : functor.map (forget C) f = ⇑f :=
  rfl

@[simp] theorem coe_id {C : Type v} [category C] [concrete_category C] {X : C} (x : ↥X) :
    coe_fn 𝟙 x = x :=
  congr_fun (functor.map_id (forget C) X) x

@[simp] theorem coe_comp {C : Type v} [category C] [concrete_category C] {X : C} {Y : C} {Z : C}
    (f : X ⟶ Y) (g : Y ⟶ Z) (x : ↥X) : coe_fn (f ≫ g) x = coe_fn g (coe_fn f x) :=
  congr_fun (functor.map_comp (forget C) f g) x

@[simp] theorem coe_hom_inv_id {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ≅ Y) (x : ↥X) : coe_fn (iso.inv f) (coe_fn (iso.hom f) x) = x :=
  congr_fun (iso.hom_inv_id (functor.map_iso (forget C) f)) x

@[simp] theorem coe_inv_hom_id {C : Type v} [category C] [concrete_category C] {X : C} {Y : C}
    (f : X ≅ Y) (y : ↥Y) : coe_fn (iso.hom f) (coe_fn (iso.inv f) y) = y :=
  congr_fun (iso.inv_hom_id (functor.map_iso (forget C) f)) y

/-- In any concrete category, injective morphisms are monomorphisms. -/
theorem concrete_category.mono_of_injective {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} (f : X ⟶ Y) (i : function.injective ⇑f) : mono f :=
  faithful_reflects_mono (forget C) (iff.mpr (mono_iff_injective ⇑f) i)

/-- In any concrete category, surjective morphisms are epimorphisms. -/
theorem concrete_category.epi_of_surjective {C : Type v} [category C] [concrete_category C] {X : C}
    {Y : C} (f : X ⟶ Y) (s : function.surjective ⇑f) : epi f :=
  faithful_reflects_epi (forget C) (iff.mpr (epi_iff_surjective ⇑f) s)

protected instance concrete_category.types : concrete_category (Type u) := concrete_category.mk 𝟭

/--
`has_forget₂ C D`, where `C` and `D` are both concrete categories, provides a functor
`forget₂ C D : C ⥤ D` and a proof that `forget₂ ⋙ (forget D) = forget C`.
-/
class has_forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
    [concrete_category D]
    where
  forget₂ : C ⥤ D
  forget_comp :
    autoParam (forget₂ ⋙ forget D = forget C)
      (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.obviously")
        (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "obviously") [])

/-- The forgetful functor `C ⥤ D` between concrete categories for which we have an instance
`has_forget₂ C `. -/
def forget₂ (C : Type v) (D : Type v') [category C] [concrete_category C] [category D]
    [concrete_category D] [has_forget₂ C D] : C ⥤ D :=
  has_forget₂.forget₂

protected instance forget_faithful (C : Type v) (D : Type v') [category C] [concrete_category C]
    [category D] [concrete_category D] [has_forget₂ C D] : faithful (forget₂ C D) :=
  eq.faithful_of_comp has_forget₂.forget_comp

protected instance induced_category.concrete_category {C : Type v} {D : Type v'} [category D]
    [concrete_category D] (f : C → D) : concrete_category (induced_category D f) :=
  concrete_category.mk (induced_functor f ⋙ forget D)

protected instance induced_category.has_forget₂ {C : Type v} {D : Type v'} [category D]
    [concrete_category D] (f : C → D) : has_forget₂ (induced_category D f) D :=
  has_forget₂.mk (induced_functor f)

/--
In order to construct a “partially forgetting” functor, we do not need to verify functor laws;
it suffices to ensure that compositions agree with `forget₂ C D ⋙ forget D = forget C`.
-/
def has_forget₂.mk' {C : Type v} {D : Type v'} [category C] [concrete_category C] [category D]
    [concrete_category D] (obj : C → D)
    (h_obj : ∀ (X : C), functor.obj (forget D) (obj X) = functor.obj (forget C) X)
    (map : {X Y : C} → (X ⟶ Y) → (obj X ⟶ obj Y))
    (h_map : ∀ {X Y : C} {f : X ⟶ Y}, functor.map (forget D) (map f) == functor.map (forget C) f) :
    has_forget₂ C D :=
  has_forget₂.mk
    (faithful.div (forget C) (forget D) (fun (X : C) => obj X) h_obj
      (fun (X Y : C) (f : X ⟶ Y) => map f) h_map)

protected instance has_forget_to_Type (C : Type v) [category C] [concrete_category C] :
    has_forget₂ C (Type u) :=
  has_forget₂.mk (forget C)

end Mathlib


import ..quotient
import ..transition.iff_lemmas

open mcrl2

variable {α : Type}
variable [comm_semigroup_with_zero α]

/- Here we prove the congruence rules for the operators. -/
inductive R_alt {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ (x y) (h : R₁ x y) : R_alt x y
| R₂ (x y) (h : R₂ x y) : R_alt x y
| basel : R_alt (x₁ + y₁) (x₂ + y₂)
| baser : R_alt (x₂ + y₂) (x₁ + y₁)

theorem bisim.alt (x₁ x₂ y₁ y₂: mcrl2 α) (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂):
 x₁ + y₁ ≈ x₂ + y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim, R₁_symm⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim, R₂_symm⟩,
  apply exists.intro (R_alt R₁ R₂),
  apply and.intro,
  { apply R_alt.basel},
  { apply and.intro,
    { intros x y x' a Rxy hxax',
      cases Rxy,
      { have h : ∃ y', transition y a y' ∧ option.rel R₁ x' y',
        by exact bisim_lift (and.intro R₁_bisim R₁_symm) Rxy_h hxax',
        exact bisim_exists_lift R_alt.R₁ h},
      { have h : ∃ y', transition y a y' ∧ option.rel R₂ x' y',
        by exact bisim_lift (and.intro R₂_bisim R₂_symm) Rxy_h hxax',
        exact bisim_exists_lift R_alt.R₂ h},
      { simp only [transition.alt_iff, or_and_distrib_right, exists_or_distrib],
        cases hxax',
        { have h : ∃y', transition x₂ a y' ∧ option.rel R₁ x' y',
          by exact bisim_lift (and.intro R₁_bisim R₁_symm) R₁x hxax'_h,
          left,
          apply bisim_exists_lift R_alt.R₁ h},
        { have h : ∃y', transition y₂ a y' ∧ option.rel R₂ x' y',
          by exact bisim_lift (and.intro R₂_bisim R₂_symm) R₂y hxax'_h,
          right,
          apply bisim_exists_lift R_alt.R₂ h}},
      { simp only [transition.alt_iff, or_and_distrib_right, exists_or_distrib],
        cases hxax',
        { have R₁x' : R₁ x₂ x₁, by apply R₁_symm R₁x,
          have h : ∃y', transition x₁ a y' ∧ option.rel R₁ x' y',
          by exact bisim_lift (and.intro R₁_bisim R₁_symm) R₁x' hxax'_h,
          left,
          apply bisim_exists_lift R_alt.R₁ h},
        { have R₂y' : R₂ y₂ y₁, by apply R₂_symm R₂y,
          have h : ∃y', transition y₁ a y' ∧ option.rel R₂ x' y',
          by exact bisim_lift (and.intro R₂_bisim R₂_symm) R₂y' hxax'_h,
          right,
          apply bisim_exists_lift R_alt.R₂ h}}},
    { intros x y h,
      cases h,
      { apply R_alt.R₁,
        exact R₁_symm h_h},
      { apply R_alt.R₂,
        exact R₂_symm h_h},
      { exact R_alt.baser},
      { exact R_alt.basel}}}
end

inductive R_seq {x₁ x₂ y₁ y₂ : mcrl2 α} (R₁ R₂ : mcrl2 α → mcrl2 α → Prop) :
mcrl2 α → mcrl2 α → Prop
| R₁ (x y) (h : R₁ x y) : R_seq x y
| R₂ (x y) (h : R₂ x y) : R_seq x y
| basel : R_seq (x₁ ⬝ y₁) (x₂ ⬝ y₂)
| baser : R_seq (x₂ ⬝ y₂) (x₁ ⬝ y₁)
| stepl {x y} (h : R₁ x y) : R_seq (x ⬝ y₁) (y ⬝ y₂)
| stepr {x y} (h : R₁ x y) : R_seq (y ⬝ y₂) (x ⬝ y₁)

lemma bisim_exists_lift_seq {x₁ x₂ y₁ y₂ y a x'} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hR₂ : R₂ y₁ y₂):
(∃y', transition y a y' ∧ option.rel R₁ x' y') → (∃y', transition y a y' ∧ option.rel (@R_seq _ _ x₁ x₂ y₁ y₂ R₁ R₂) (seq' x' y₁) (seq' y' y₂)) :=
begin
  intro h,
  cases h with w h_w,
  cases h_w with l r,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases r,
  { cases r,
    apply option.rel.some,
    apply R_seq.stepl,
    assumption},
  { apply option.rel.some,
    apply R_seq.R₂,
    assumption}
end

lemma bisim_exists_lift_seq_symm {x₁ x₂ y₁ y₂ y a x'} {R₁ R₂  : mcrl2 α → mcrl2 α → Prop}
 (hR₂ : R₂ y₂ y₁) (R₁_symm : symmetric R₁):
(∃y', transition y a y' ∧ option.rel R₁ x' y') → (∃y', transition y a y' ∧ option.rel (@R_seq _ _ x₁ x₂ y₁ y₂ R₁ R₂) (seq' x' y₂) (seq' y' y₁)) :=
begin
  intro h,
  cases h with w h_w,
  cases h_w with l r,
  apply exists.intro w,
  apply and.intro,
  assumption,
  cases r,
  { cases r,
    apply option.rel.some,
    apply R_seq.stepr,
    apply R₁_symm,
    assumption},
  { apply option.rel.some,
    apply R_seq.R₂,
    assumption}
end

theorem bisim.seq {x₁ x₂ y₁ y₂: mcrl2 α} (h₁ : x₁ ≈ x₂) (h₂ : y₁ ≈ y₂) :
 x₁ ⬝ y₁ ≈ x₂ ⬝ y₂ :=
begin
  rcases h₁ with ⟨R₁, R₁x, R₁_bisim, R₁_symm⟩,
  rcases h₂ with ⟨R₂, R₂y, R₂_bisim, R₂_symm⟩,
  apply exists.intro (R_seq R₁ R₂),
  apply and.intro,
  { apply R_seq.basel},
  { apply and.intro,
    { intros x y x' a Rxy xax',
      cases Rxy,
      { have h: ∃y', transition y a y' ∧ option.rel R₁ x' y',
        by exact bisim_lift (and.intro R₁_bisim R₁_symm) Rxy_h xax',
        exact bisim_exists_lift R_seq.R₁ h},
      { have h: ∃y', transition y a y' ∧ option.rel R₂ x' y',
        by exact bisim_lift (and.intro R₂_bisim R₂_symm) Rxy_h xax',
        exact bisim_exists_lift R_seq.R₂ h},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim x₁ x₂ xax'_z a R₁x xax'_h,
        apply bisim_exists_lift_seq,
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim x₂ x₁ xax'_z a (R₁_symm R₁x) xax'_h,
        apply bisim_exists_lift_seq_symm,
        exact (R₂_symm R₂y),
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim Rxy_x Rxy_y xax'_z a Rxy_h xax'_h,
        apply bisim_exists_lift_seq,
        repeat {assumption}},
      { cases xax',
        simp only [transition.seq_iff, ←exists_and_distrib_right, and_assoc, exists_comm, exists_eq_left],
        specialize R₁_bisim Rxy_y Rxy_x xax'_z a (R₁_symm Rxy_h) xax'_h,
        apply bisim_exists_lift_seq_symm,
        exact (R₂_symm R₂y),
        repeat {assumption}}},
    { intros x y h,
      cases h,
      { apply R_seq.R₁,
        apply R₁_symm,
        assumption},
      { apply R_seq.R₂,
        apply R₂_symm,
        assumption},
      { exact R_seq.baser},
      { exact R_seq.basel},
      { exact R_seq.stepr h_h},
      { exact R_seq.stepl h_h}}}
end


-- This was written by Tim (who?) in 2017, but the codebase has moved on and I haven't
-- been able to maintain it.
-- In any case, there was never a clear main statement, and I think I'd prefer to do this
-- much more explicitly by giving an equivalence to a strictly monoidal category.

-- import .monoidal_category
-- import .util.data.nonempty_list
-- import .util.data.bin_tree
-- import .util.data.bin_tree.cong_clos

-- import tidy.congr_struct

-- open categories
-- open categories.monoidal_category
-- open util.data.nonempty_list
-- open util.data.bin_tree'
-- open util.data.bin_tree'.bin_tree'

-- namespace categories.monoidal_category.coherence_thm

-- universes u v

-- variable {α : Type u}

-- inductive reassoc_dir_single_step : bin_tree' α → bin_tree' α → Type u
-- | rotate_right : Π r s t, reassoc_dir_single_step (branch (branch r s) t) (branch r (branch s t))

-- namespace reassoc_dir_single_step

-- lemma respects_to_list : Π (s t : bin_tree' α), reassoc_dir_single_step s t → s.to_list = t.to_list
-- | ._ ._ (rotate_right _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end

-- end reassoc_dir_single_step

-- @[reducible] def reassoc_dir_step : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos_step reassoc_dir_single_step

-- namespace reassoc_dir_step

-- lemma respects_lopsided {s t : bin_tree' α} (p : reassoc_dir_step s t) : s.lopsided = t.lopsided :=
--   cong_clos_step.respects_lopsided reassoc_dir_single_step.respects_to_list p

-- end reassoc_dir_step

-- @[reducible] def reassoc_dir : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos reassoc_dir_single_step

-- @[reducible] def reassoc_dir' : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos' reassoc_dir_single_step

-- namespace reassoc_dir

-- @[reducible] def refl (t : bin_tree' α) : reassoc_dir t t := cong_clos.refl _ t

-- def rotate_right (r s t : bin_tree' α) : reassoc_dir (branch (branch r s) t) (branch r (branch s t)) :=
--   cong_clos.lift (reassoc_dir_single_step.rotate_right _ _ _)

-- def lopsided_combine : Π (xs ys : nonempty_list α),
--     reassoc_dir (branch (from_list_lopsided xs) (from_list_lopsided ys)) (from_list_lopsided (xs ++ ys))
-- | (nonempty_list.singleton x) ys := refl _
-- | (nonempty_list.cons x xs)   ys :=
--   begin
--     simp, unfold from_list_lopsided,
--     apply cong_clos.trans,
--       apply rotate_right,
--       apply cong_clos.cong,
--         apply reassoc_dir.refl,
--         apply lopsided_combine
--   end

-- def reassoc_lopsided : Π (t : bin_tree' α), reassoc_dir t t.lopsided
-- | (leaf x)     := refl _
-- | (branch l r) :=
--   begin
--     apply cong_clos.trans,
--       apply cong_clos.cong,
--         apply reassoc_lopsided,
--         apply reassoc_lopsided,
--     apply lopsided_combine
--   end

-- lemma reassoc_already_lopsided :
--     Π (l : nonempty_list α),
--     reassoc_lopsided (bin_tree'.from_list_lopsided l) == refl (bin_tree'.from_list_lopsided l)
-- | (nonempty_list.singleton x) := by reflexivity
-- | (nonempty_list.cons x xs)   :=
--     calc
--           cong_clos.trans
--             (cong_clos.inject_right _ (reassoc_lopsided (from_list_lopsided xs)))
--             (refl (branch (leaf x) (from_list_lopsided (to_list (from_list_lopsided xs)))))
--         = cong_clos.inject_right (leaf x) (reassoc_lopsided (from_list_lopsided xs))
--         : by apply cong_clos.trans_refl_right
--     ... == cong_clos.inject_right (leaf x) (refl (from_list_lopsided xs))
--         : begin
--             congr_args,
--               unfold lopsided, rewrite from_list_lopsided_to_list,
--               apply reassoc_already_lopsided
--           end
--     ... == refl (branch (leaf x) (from_list_lopsided xs))
--         : by reflexivity

-- lemma respects_to_list {s t : bin_tree' α} (p : reassoc_dir s t) : s.to_list = t.to_list :=
--   cong_clos.respects_to_list reassoc_dir_single_step.respects_to_list p

-- lemma respects_lopsided {s t : bin_tree' α} (p : reassoc_dir s t) : s.lopsided = t.lopsided :=
--   cong_clos.respects_lopsided reassoc_dir_single_step.respects_to_list p

-- end reassoc_dir

-- inductive reassoc_single_step : bin_tree' α → bin_tree' α → Type u
-- | rotate_left  : Π r s t, reassoc_single_step (branch r (branch s t)) (branch (branch r s) t)
-- | rotate_right : Π r s t, reassoc_single_step (branch (branch r s) t) (branch r (branch s t))

-- @[reducible] def reassoc_step : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos_step reassoc_single_step

-- @[reducible] def reassoc : bin_tree' α → bin_tree' α → Type u :=
--   cong_clos reassoc_single_step

-- namespace reassoc_single_step

-- def sym : Π (x y : bin_tree' α), reassoc_single_step x y → reassoc_single_step y x
-- | ._ ._ (rotate_left  _ _ _) := rotate_right _ _ _
-- | ._ ._ (rotate_right _ _ _) := rotate_left  _ _ _

-- lemma respects_to_list : Π (s t : bin_tree' α), reassoc_single_step s t → s.to_list = t.to_list
-- | ._ ._ (rotate_left _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end
-- | ._ ._ (rotate_right _ _ _) :=
--     begin
--       unfold bin_tree'.to_list,
--       rewrite nonempty_list.append_assoc
--     end

-- end reassoc_single_step

-- def reassoc_dir_to_reassoc_single_step : Π (s t : bin_tree' α), reassoc_dir_single_step s t → reassoc_single_step s t
-- | ._ ._ (reassoc_dir_single_step.rotate_right s t u) := reassoc_single_step.rotate_right s t u

-- def reassoc_dir_to_reassoc : Π {s t : bin_tree' α}, reassoc_dir s t → reassoc s t :=
--   λ s t p, cong_clos.transport reassoc_dir_to_reassoc_single_step p

-- namespace reassoc

-- @[reducible] def refl (t : bin_tree' α) : reassoc_dir t t := cong_clos.refl _ t

-- def sym : Π {x y : bin_tree' α}, reassoc x y → reassoc y x :=
--   λ x y, cong_clos.sym reassoc_single_step.sym

-- lemma respects_to_list : Π {s t : bin_tree' α}, reassoc s t → s.to_list = t.to_list :=
--   λ x y, cong_clos.respects_to_list reassoc_single_step.respects_to_list

-- def reassoc_lopsided : Π (t : bin_tree' α), reassoc t t.lopsided :=
--   λ t, reassoc_dir_to_reassoc (reassoc_dir.reassoc_lopsided t)

-- -- TODO: more economical construction (with fewer rotations)
-- def reassoc_tree : Π (r t : bin_tree' α) (h : r.to_list = t.to_list), reassoc r t :=
-- begin
--   intros,
--   apply cong_clos.trans,
--   apply reassoc_lopsided,
--   -- TODO: doing `rewrite h` here doesn't work ~> report bug
--   apply sym,
--   unfold lopsided, rewrite h,
--   apply reassoc_lopsided
-- end

-- end reassoc

-- section interpretation

-- parameter (C : Category.{u v})
-- parameter (M : MonoidalStructure C)

-- @[reducible] def tensor : C.Obj → C.Obj → C.Obj := λ X Y, M.tensor (X, Y)

-- local infixl `⟩C⟩`:60 := C.compose

-- local infix `⊗`:60 := tensor

-- -- this is better behaved wrt type inference than `M.tensor.onMorphisms` because no tuple has to be inferred
-- @[reducible] def tensor_homs : Π {W X Y Z : C.Obj}, C.Hom W X → C.Hom Y Z → C.Hom (W ⊗ Y) (X ⊗ Z) :=
--   λ W X Y Z f g, M.tensor.onMorphisms (f, g)

-- local infix `⟨⊗⟩`:60 := tensor_homs

-- open cong_clos

-- @[reducible] def tensor_tree : bin_tree' C.Obj → C.Obj
-- | (bin_tree'.leaf A)     := A
-- | (bin_tree'.branch l r) := tensor_tree l ⊗ tensor_tree r

-- def interpret_cong_clos'
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos' R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos'.lift _ _ p)       := I _ _ p
-- | ._ ._ (cong_clos'.refl ._ t)        := C.identity _
-- | ._ ._ (cong_clos'.trans _ _ _ p q)  := C.compose (interpret_cong_clos' p) (interpret_cong_clos' q)
-- | ._ ._ (cong_clos'.cong _ _ _ _ l r) := M.tensor.onMorphisms (interpret_cong_clos' l, interpret_cong_clos' r)

-- -- the equation compiler somehow can't handle the next definitions ~> turn it off
-- -- TODO(tim): report bug
-- set_option eqn_compiler.lemmas false

-- -- TODO(tim): factor out I as a variable
-- def interpret_cong_clos_step
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos_step R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos_step.lift x y p)      := I x y p
-- | ._ ._ (cong_clos_step.left l₁ l₂ r l)  := interpret_cong_clos_step l ⟨⊗⟩ C.identity (tensor_tree r)
-- | ._ ._ (cong_clos_step.right l r₁ r₂ r) := C.identity (tensor_tree l) ⟨⊗⟩ interpret_cong_clos_step r

-- set_option eqn_compiler.lemmas true

-- def interpret_cong_clos
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π {Xs Ys : bin_tree' C.Obj}, cong_clos R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (cong_clos.refl ._ t)      := C.identity _
-- | ._ ._ (cong_clos.step _ _ _ p q) := C.compose (interpret_cong_clos_step I p) (interpret_cong_clos q)

-- lemma interpret_cong_clos_functoriality
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π (Xs Ys Zs : bin_tree' C.Obj) (ps : cong_clos R Xs Ys) (qs : cong_clos R Ys Zs),
--       interpret_cong_clos I ps ⟩C⟩ interpret_cong_clos I qs = interpret_cong_clos I (cong_clos.trans ps qs)
-- | ._ ._ _ (cong_clos.refl ._ t)       qs := C.left_identity _
-- | ._ ._ _ (cong_clos.step _ _ _ p ps) qs :=
--     begin
--       unfold cong_clos.trans,
--       unfold interpret_cong_clos,
--       rewrite C.associativity,
--       rewrite interpret_cong_clos_functoriality
--     end

-- -- TODO(tim): move this somewhere else?
-- lemma functoriality_left
--     (X Y Z A : C.Obj)
--     (f : C.Hom X Y) (g : C.Hom Y Z)
--     : (f ⟩C⟩ g) ⟨⊗⟩ C.identity A = (f ⟨⊗⟩ C.identity A) ⟩C⟩ (g ⟨⊗⟩ C.identity A) := ♯

-- lemma interpret_cong_clos_inject_left
--     {R : bin_tree' C.Obj → bin_tree' C.Obj → Type u}
--     (I : Π (Xs Ys : bin_tree' C.Obj), R Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys))
--     : Π (Xs Ys Zs : bin_tree' C.Obj) (ps : cong_clos R Xs Ys),
--       interpret_cong_clos I (inject_left Zs ps) = interpret_cong_clos I ps ⟨⊗⟩ C.identity (tensor_tree Zs)
-- | ._ ._ _ (cong_clos.refl ._ _)       := by {symmetry, apply M.tensor.identities}
-- | ._ ._ _ (cong_clos.step _ _ _ p ps) :=
--   begin
--     unfold inject_left,
--     unfold interpret_cong_clos,
--     rewrite functoriality_left,
--     rewrite (interpret_cong_clos_inject_left _ _ _ ps),
--     reflexivity
--   end

-- -- TODO(tim): it would be cool if interpretation were a real functor from a suitable formal category

-- def interpret_reassoc_dir_single_step : Π (Xs Ys : bin_tree' C.Obj), reassoc_dir_single_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (reassoc_dir_single_step.rotate_right s t u) := M.associator _ _ _

-- def interpret_reassoc_dir {Xs Ys : bin_tree' C.Obj} : reassoc_dir Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos interpret_reassoc_dir_single_step

-- lemma interpret_reassoc_dir_functoriality
--     {Xs Ys Zs : bin_tree' C.Obj} (ps : reassoc_dir Xs Ys) (qs : reassoc_dir Ys Zs)
--     : interpret_reassoc_dir ps ⟩C⟩ interpret_reassoc_dir qs = interpret_reassoc_dir (cong_clos.trans ps qs)
--   := by apply interpret_cong_clos_functoriality

-- def interpret_reassoc_dir' {Xs Ys : bin_tree' C.Obj} : reassoc_dir' Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos' interpret_reassoc_dir_single_step

-- def interpret_reassoc_dir_step {Xs Ys : bin_tree' C.Obj} : reassoc_dir_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos_step interpret_reassoc_dir_single_step

-- def interpret_reassoc_single_step : Π (Xs Ys : bin_tree' C.Obj), reassoc_single_step Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys)
-- | ._ ._ (reassoc_single_step.rotate_right s t u) := M.associator _ _ _
-- | ._ ._ (reassoc_single_step.rotate_left  s t u) := M.inverse_associator _ _ _

-- def interpret_reassoc {Xs Ys : bin_tree' C.Obj} : reassoc Xs Ys → C.Hom (tensor_tree Xs) (tensor_tree Ys) :=
--   interpret_cong_clos interpret_reassoc_single_step

-- @[reducible] def to_lopsided (t : bin_tree' C.Obj) : C.Hom (tensor_tree t) (tensor_tree t.lopsided) :=
--   interpret_reassoc_dir (reassoc_dir.reassoc_lopsided t)

-- -- TODO: generalize to cong_clos
-- def rewrite_source : Π {s₁ s₂ t : bin_tree' α} (eq : s₁ = s₂), reassoc_dir s₁ t → reassoc_dir s₂ t
-- | _ ._ _ (eq.refl ._) p := p

-- -- TODO: generalize to cong_clos
-- def rewrite_target : Π {s t₁ t₂ : bin_tree' α} (eq : t₁ = t₂), reassoc_dir s t₁ → reassoc_dir s t₂
-- | _ ._ _ (eq.refl ._) p := p

-- -- TODO: generalize to cong_clos
-- def rewrite_target_cong : Π {s t₁ t₂ : bin_tree' α} (eq : t₁ = t₂) (p : reassoc_dir s t₁), rewrite_target eq p == p
-- | _ _ ._ (eq.refl ._) p := heq.refl _

-- @[reducible] def trans_lopsided' {s t : bin_tree' α} (p : reassoc_dir s t) : reassoc_dir s t.lopsided :=
--   cong_clos.trans p (reassoc_dir.reassoc_lopsided t)

-- -- all roads lead to rome
-- def trans_lopsided {s t : bin_tree' α} (p : reassoc_dir s t) : reassoc_dir s s.lopsided :=
--   rewrite_target (eq.symm (reassoc_dir.respects_lopsided p)) (trans_lopsided' p)

-- lemma trans_lopsided_heq {s t : bin_tree' α} (p : reassoc_dir s t) : trans_lopsided p == trans_lopsided' p :=
--   by apply rewrite_target_cong

-- lemma trans_lopsided_already_lopsided {s : bin_tree' α} (p : reassoc_dir s s.lopsided) : trans_lopsided p == p :=
--   calc
--          rewrite_target (eq.symm (reassoc_dir.respects_lopsided p)) (cong_clos.trans p (reassoc_dir.reassoc_lopsided s.lopsided))
--       == cong_clos.trans p (reassoc_dir.reassoc_lopsided s.lopsided)
--       : by apply rewrite_target_cong
--   ... == cong_clos.trans p (reassoc_dir.refl s.lopsided)
--       : begin
--           congr_args, rewrite lopsided_idempotent, apply reassoc_dir.reassoc_already_lopsided
--         end
--   ... = p
--       : by apply trans_refl_right

-- @[reducible] def step_lopsided' {s t : bin_tree' α} (p : reassoc_dir_step s t) : reassoc_dir s t.lopsided :=
--   cong_clos.step _ _ _ p (reassoc_dir.reassoc_lopsided t)

-- def step_lopsided {s t : bin_tree' α} (p : reassoc_dir_step s t) : reassoc_dir s s.lopsided :=
--   rewrite_target (eq.symm (reassoc_dir_step.respects_lopsided p)) (step_lopsided' p)

-- lemma step_lopsided_heq {s t : bin_tree' α} (p : reassoc_dir_step s t) : step_lopsided p == step_lopsided' p :=
--   by apply rewrite_target_cong

-- -- -- TODO(tim): use well-founded induction once lean supports it
-- -- -- TODO(tim): why does lean complain that there are missing cases???
-- -- meta lemma directed_associator_coherence_thm :
-- --     Π (Xs Ys : bin_tree' C.Obj) (e : Ys = Xs.lopsided)
-- --       (p q : reassoc_dir Xs Ys),
-- --       interpret_reassoc_dir p = interpret_reassoc_dir q
-- -- | (branch l r) ._ (eq.refl ._) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lp ._ p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lq ._ q) qs) :=
-- --     have H : Π (l' : bin_tree' C.Obj) (f : reassoc_dir_step l l') (fs : reassoc_dir (branch l' r) (branch l r).lopsided),
-- --                interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r f) fs) ==
-- --                (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r), from
-- --         λ l' f fs,
-- --         have e₀ : lopsided l = lopsided l', from
-- --           by {apply reassoc_dir_step.respects_lopsided, assumption},
-- --         have e₁ : lopsided (branch l r) = lopsided (branch l' r), from
-- --           by {apply reassoc_dir_step.respects_lopsided, apply cong_clos_step.left, assumption},
-- --         have e₂ : lopsided (branch l' r) = lopsided (branch (lopsided l') r), from
-- --           by {unfold lopsided, congr_args, unfold to_list, rewrite from_list_lopsided_to_list},
-- --         have e₃ : interpret_reassoc_dir fs == (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r)), from
-- --             calc
-- --                   interpret_reassoc_dir fs
-- --                 == interpret_reassoc_dir (rewrite_target e₁ fs)
-- --                 :  by {congr_args, assumption, symmetry, apply rewrite_target_cong}
-- --             ... =  interpret_reassoc_dir (trans_lopsided (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')))
-- --                 :  by apply directed_associator_coherence_thm (branch l' r) (branch l' r).lopsided (eq.refl _)
-- --             ... == interpret_reassoc_dir (trans_lopsided' (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')))
-- --                 :  by {congr_args, assumption, apply trans_lopsided_heq}
-- --             ... =  interpret_reassoc_dir (cong_clos.inject_left r (reassoc_dir.reassoc_lopsided l')) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --                 :  by {symmetry, apply interpret_reassoc_dir_functoriality}
-- --             ... =  (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --                 :  by {congr_args, apply interpret_cong_clos_inject_left},
-- --         calc
-- --                 (interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ interpret_reassoc_dir fs
-- --             == (interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ ((interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r)))
-- --             :  by {congr_args, cc, assumption}
-- --         ... == ((interpret_reassoc_dir_step f ⟨⊗⟩ C.identity _) ⟩C⟩ (interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l') ⟨⊗⟩ C.identity (tensor_tree r))) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  ♮
-- --         ... == ((interpret_reassoc_dir_step f ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided l')) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  by rewrite functoriality_left
-- --         ... == (interpret_reassoc_dir (cong_clos.step _ _ _ f (reassoc_dir.reassoc_lopsided l')) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l'.lopsided r))
-- --             :  by reflexivity
-- --         ... == (interpret_reassoc_dir (step_lopsided f) ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ interpret_reassoc_dir (reassoc_dir.reassoc_lopsided (branch l.lopsided r))
-- --             :  begin
-- --                  congr_args,
-- --                   {cc},
-- --                   {cc},
-- --                   {congr_args, cc, congr_args, cc, symmetry, apply step_lopsided_heq},
-- --                   {cc}
-- --                end
-- --         ... = (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r)
-- --             :  by {congr_args, congr_args, apply directed_associator_coherence_thm l l.lopsided (eq.refl _)},
-- --     eq_of_heq $
-- --     calc
-- --            interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r p) ps)
-- --         == (to_lopsided l ⟨⊗⟩ C.identity (tensor_tree r)) ⟩C⟩ to_lopsided (branch l.lopsided r)
-- --         :  by apply H
-- --     ... == interpret_reassoc_dir (step (branch l r) _ _ (cong_clos_step.left _ _ r q) qs)
-- --         :  by {symmetry, apply H}
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rp p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rq q) qs) := sorry
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lp ._ p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rq q) qs) := sorry
-- -- | (branch l r) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.right ._ ._ rp p) ps) (cong_clos.step ._ ._ ._ (cong_clos_step.left ._ lq ._ q) qs) := sorry
-- -- | (branch (branch x y) z) Ys e (cong_clos.step ._ ._ ._ (cong_clos_step.lift ._ ._ (reassoc_dir_single_step.rotate_right ._ ._ ._)) _) (cong_clos.step ._ _ ._ _ _) := sorry
-- -- | (branch (branch x y) z) Ys e (cong_clos.step ._ _ ._ _ _) (cong_clos.step ._ ._ ._ (cong_clos_step.lift ._ ._ (reassoc_dir_single_step.rotate_right ._ ._ ._)) _) := sorry
-- -- | Xs ._ e (cong_clos.refl ._ ._) (cong_clos.step ._ t' ._ q _) := sorry
-- -- | Xs ._ e (cong_clos.step ._ t' ._ p _) (cong_clos.refl ._ ._) := sorry
-- -- | Xs ._ e (cong_clos.refl ._ ._) (cong_clos.refl ._ ._) := sorry

-- end interpretation

-- end categories.monoidal_category.coherence_thm


import rowround

import category_theory.category.basic
import category_theory.core

open params
open operations
open quarterround
open rowround
open utils

open category_theory

namespace columnround

variables [category (bitvec word_len)]

/-!
  # Columnround

  The `columnround` function and the relation with its inverse.
-/

/-!
  ## Definitions and lemmas
-/

/--  Without ordering for inputs, a `columnround` is exactly the same as a `rowround`. -/
@[simp] def columnround (M : matrixType) : matrixType := rowround M

/--  Without ordering for inputs, a `columnround_inv` is exactly the same as a `rowround_inv`. -/
@[simp] def columnround_inv (M : matrixType) : matrixType := rowround_inv M

/- Just some notation for inverses. -/
local notation `columnround⁻¹` := columnround_inv

/-- The `columnround` function is invertible. -/
lemma columnround_is_inv (I : columnround ≅ columnround⁻¹) : I.hom ≫ I.inv = 𝟙 columnround :=
  by rw [iso.hom_inv_id]

/-- This columnround call will sort all the elements of the input and the output to match salsa20.
-- It should be used in `doubleround`.-/
@[simp] def columnround_salsa20 (M : matrixType) := columnround_output (columnround (columnround_input M))

/-- This columnround inverse call will sort all the elements of the input and the output to match salsa20.
It should be used in `doubleround`. -/
@[simp] def columnround_salsa20_inv (M : matrixType) := columnround_output (columnround⁻¹ (columnround_input M))

/- Just some notation for inverses. -/
local notation `columnround_salsa20⁻¹` := columnround_salsa20_inv

/-- The `columnround` function is invertible. -/
lemma columnround_salsa20_is_inv (I : columnround_salsa20 ≅ columnround_salsa20⁻¹) :
  I.hom ≫ I.inv = 𝟙 columnround_salsa20 := by rw [iso.hom_inv_id]

end columnround


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton, Johan Commelin
-/
import category_theory.adjunction.basic
import category_theory.limits.creates

open opposite

namespace category_theory.adjunction
open category_theory
open category_theory.functor
open category_theory.limits

universes u₁ u₂ v

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

variables {F : C ⥤ D} {G : D ⥤ C} (adj : F ⊣ G)
include adj

section preservation_colimits
variables {J : Type v} [small_category J] (K : J ⥤ C)

/--
The right adjoint of `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
def functoriality_right_adjoint : cocone (K ⋙ F) ⥤ cocone K :=
(cocones.functoriality _ G) ⋙
  (cocones.precompose (K.right_unitor.inv ≫ (whisker_left K adj.unit) ≫ (associator _ _ _).inv))

local attribute [reducible] functoriality_right_adjoint

/--
The unit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_unit :
  𝟭 (cocone K) ⟶ cocones.functoriality _ F ⋙ functoriality_right_adjoint adj K :=
{ app := λ c, { hom := adj.unit.app c.X } }

/--
The counit for the adjunction for `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)`.

Auxiliary definition for `functoriality_is_left_adjoint`.
-/
@[simps] def functoriality_counit :
  functoriality_right_adjoint adj K ⋙ cocones.functoriality _ F ⟶ 𝟭 (cocone (K ⋙ F)) :=
{ app := λ c, { hom := adj.counit.app c.X } }

/-- The functor `cocones.functoriality K F : cocone K ⥤ cocone (K ⋙ F)` is a left adjoint. -/
def functoriality_is_left_adjoint :
  is_left_adjoint (cocones.functoriality K F) :=
{ right := functoriality_right_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit adj K,
    counit := functoriality_counit adj K } }

/--
A left adjoint preserves colimits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def left_adjoint_preserves_colimits : preserves_colimits F :=
{ preserves_colimits_of_shape := λ J 𝒥,
  { preserves_colimit := λ F,
    by exactI
    { preserves := λ c hc, is_colimit.iso_unique_cocone_morphism.inv
        (λ s, @equiv.unique _ _ (is_colimit.iso_unique_cocone_morphism.hom hc _)
          (((adj.functoriality_is_left_adjoint _).adj).hom_equiv _ _)) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_colimits (E : C ⥤ D) [is_equivalence E] : preserves_colimits E :=
left_adjoint_preserves_colimits E.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_colimits (E : D ⥤ C) [is_equivalence E] : reflects_colimits E :=
{ reflects_colimits_of_shape := λ J 𝒥, by exactI
  { reflects_colimit := λ K,
    { reflects := λ c t,
      begin
        have l := (is_colimit_of_preserves E.inv t).map_cocone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_colimit.precompose_inv_equiv K.right_unitor _).symm) l).of_iso_colimit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_colimits (H : D ⥤ C) [is_equivalence H] : creates_colimits H :=
{ creates_colimits_of_shape := λ J 𝒥, by exactI
  { creates_colimit := λ F,
    { lifts := λ c t,
      { lifted_cocone := H.map_cocone_inv c,
        valid_lift := H.map_cocone_map_cocone_inv c } } } }

-- verify the preserve_colimits instance works as expected:
example (E : C ⥤ D) [is_equivalence E]
  (c : cocone K) (h : is_colimit c) : is_colimit (E.map_cocone c) :=
preserves_colimit.preserves h

instance has_colimit_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit K] :
  has_colimit (K ⋙ E) :=
has_colimit.mk
{ cocone := E.map_cocone (colimit.cocone K),
  is_colimit := preserves_colimit.preserves (colimit.is_colimit K) }

lemma has_colimit_of_comp_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimit (K ⋙ E)] :
  has_colimit K :=
@has_colimit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@adjunction.has_colimit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((functor.right_unitor _).symm ≪≫ iso_whisker_left K (E.as_equivalence.unit_iso))

/-- Transport a `has_colimits_of_shape` instance across an equivalence. -/
lemma has_colimits_of_shape_of_equivalence (E : C ⥤ D) [is_equivalence E]
  [has_colimits_of_shape J D] : has_colimits_of_shape J C :=
⟨λ F, by exactI has_colimit_of_comp_equivalence F E⟩

/-- Transport a `has_colimits` instance across an equivalence. -/
lemma has_colimits_of_equivalence (E : C ⥤ D) [is_equivalence E] [has_colimits D] :
  has_colimits C :=
⟨λ J hJ, by exactI has_colimits_of_shape_of_equivalence E⟩

end preservation_colimits

section preservation_limits
variables {J : Type v} [small_category J] (K : J ⥤ D)

/--
The left adjoint of `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
def functoriality_left_adjoint : cone (K ⋙ G) ⥤ cone K :=
(cones.functoriality _ F) ⋙ (cones.postcompose
    ((associator _ _ _).hom ≫ (whisker_left K adj.counit) ≫ K.right_unitor.hom))

local attribute [reducible] functoriality_left_adjoint

/--
The unit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_unit' :
  𝟭 (cone (K ⋙ G)) ⟶ functoriality_left_adjoint adj K ⋙ cones.functoriality _ G :=
{ app := λ c, { hom := adj.unit.app c.X, } }

/--
The counit for the adjunction for`cones.functoriality K G : cone K ⥤ cone (K ⋙ G)`.

Auxiliary definition for `functoriality_is_right_adjoint`.
-/
@[simps] def functoriality_counit' :
  cones.functoriality _ G ⋙ functoriality_left_adjoint adj K ⟶ 𝟭 (cone K) :=
{ app := λ c, { hom := adj.counit.app c.X, } }

/-- The functor `cones.functoriality K G : cone K ⥤ cone (K ⋙ G)` is a right adjoint. -/
def functoriality_is_right_adjoint :
  is_right_adjoint (cones.functoriality K G) :=
{ left := functoriality_left_adjoint adj K,
  adj := mk_of_unit_counit
  { unit := functoriality_unit' adj K,
    counit := functoriality_counit' adj K } }

/--
A right adjoint preserves limits.

See https://stacks.math.columbia.edu/tag/0038.
-/
def right_adjoint_preserves_limits : preserves_limits G :=
{ preserves_limits_of_shape := λ J 𝒥,
  { preserves_limit := λ K,
    by exactI
    { preserves := λ c hc, is_limit.iso_unique_cone_morphism.inv
        (λ s, @equiv.unique _ _ (is_limit.iso_unique_cone_morphism.hom hc _)
          (((adj.functoriality_is_right_adjoint _).adj).hom_equiv _ _).symm) } } }.

omit adj

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_preserves_limits (E : D ⥤ C) [is_equivalence E] : preserves_limits E :=
right_adjoint_preserves_limits E.inv.adjunction

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_reflects_limits (E : D ⥤ C) [is_equivalence E] : reflects_limits E :=
{ reflects_limits_of_shape := λ J 𝒥, by exactI
  { reflects_limit := λ K,
    { reflects := λ c t,
      begin
        have := (is_limit_of_preserves E.inv t).map_cone_equiv E.as_equivalence.unit_iso.symm,
        refine (((is_limit.postcompose_hom_equiv K.left_unitor _).symm) this).of_iso_limit _,
        tidy,
      end } } }

@[priority 100] -- see Note [lower instance priority]
instance is_equivalence_creates_limits (H : D ⥤ C) [is_equivalence H] : creates_limits H :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ F,
    { lifts := λ c t,
      { lifted_cone := H.map_cone_inv c,
        valid_lift := H.map_cone_map_cone_inv c } } } }

-- verify the preserve_limits instance works as expected:
example (E : D ⥤ C) [is_equivalence E]
  (c : cone K) [h : is_limit c] : is_limit (E.map_cone c) :=
preserves_limit.preserves h

instance has_limit_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit K] :
  has_limit (K ⋙ E) :=
has_limit.mk
{ cone := E.map_cone (limit.cone K),
  is_limit := preserves_limit.preserves (limit.is_limit K) }

lemma has_limit_of_comp_equivalence (E : D ⥤ C) [is_equivalence E] [has_limit (K ⋙ E)] :
  has_limit K :=
@has_limit_of_iso _ _ _ _ (K ⋙ E ⋙ inv E) K
(@adjunction.has_limit_comp_equivalence _ _ _ _ _ _ (K ⋙ E) (inv E) _ _)
((iso_whisker_left K E.as_equivalence.unit_iso.symm) ≪≫ (functor.right_unitor _))

/-- Transport a `has_limits_of_shape` instance across an equivalence. -/
lemma has_limits_of_shape_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits_of_shape J C] :
  has_limits_of_shape J D :=
⟨λ F, by exactI has_limit_of_comp_equivalence F E⟩

/-- Transport a `has_limits` instance across an equivalence. -/
lemma has_limits_of_equivalence (E : D ⥤ C) [is_equivalence E] [has_limits C] : has_limits D :=
⟨λ J hJ, by exactI has_limits_of_shape_of_equivalence E⟩

end preservation_limits

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_hom {J : Type v} [small_category J] {K : J ⥤ C}
  (Y : D) (t : ((cocones J D).obj (op (K ⋙ F))).obj Y) :
  (G ⋙ (cocones J C).obj (op K)).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y) (t.app j),
  naturality' := λ j j' f, by { erw [← adj.hom_equiv_naturality_left, t.naturality], dsimp, simp } }

/-- auxiliary construction for `cocones_iso` -/
@[simps]
def cocones_iso_component_inv {J : Type v} [small_category J] {K : J ⥤ C}
  (Y : D) (t : (G ⋙ (cocones J C).obj (op K)).obj Y) :
  ((cocones J D).obj (op (K ⋙ F))).obj Y :=
{ app := λ j, (adj.hom_equiv (K.obj j) Y).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_left_symm, ← adj.hom_equiv_naturality_right_symm, t.naturality],
    dsimp, simp
  end }

/--
When `F ⊣ G`,
the functor associating to each `Y` the cocones over `K ⋙ F` with cone point `Y`
is naturally isomorphic to
the functor associating to each `Y` the cocones over `K` with cone point `G.obj Y`.
-/
-- Note: this is natural in K, but we do not yet have the tools to formulate that.
def cocones_iso {J : Type v} [small_category J] {K : J ⥤ C} :
  (cocones J D).obj (op (K ⋙ F)) ≅ G ⋙ ((cocones J C).obj (op K)) :=
nat_iso.of_components (λ Y,
{ hom := cocones_iso_component_hom adj Y,
  inv := cocones_iso_component_inv adj Y, })
(by tidy)

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_hom {J : Type v} [small_category J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : (functor.op F ⋙ (cones J D).obj K).obj X) :
  ((cones J C).obj (K ⋙ G)).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)) (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right, ← t.naturality, category.id_comp, category.id_comp],
    refl
  end }

/-- auxiliary construction for `cones_iso` -/
@[simps]
def cones_iso_component_inv {J : Type v} [small_category J] {K : J ⥤ D}
  (X : Cᵒᵖ) (t : ((cones J C).obj (K ⋙ G)).obj X) :
  (functor.op F ⋙ (cones J D).obj K).obj X :=
{ app := λ j, (adj.hom_equiv (unop X) (K.obj j)).symm (t.app j),
  naturality' := λ j j' f,
  begin
    erw [← adj.hom_equiv_naturality_right_symm, ← t.naturality, category.id_comp, category.id_comp]
  end }

-- Note: this is natural in K, but we do not yet have the tools to formulate that.
/--
When `F ⊣ G`,
the functor associating to each `X` the cones over `K` with cone point `F.op.obj X`
is naturally isomorphic to
the functor associating to each `X` the cones over `K ⋙ G` with cone point `X`.
-/
def cones_iso {J : Type v} [small_category J] {K : J ⥤ D} :
  F.op ⋙ ((cones J D).obj K) ≅ (cones J C).obj (K ⋙ G) :=
nat_iso.of_components (λ X,
{ hom := cones_iso_component_hom adj X,
  inv := cones_iso_component_inv adj X, } )
(by tidy)

end category_theory.adjunction


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.ext
import Mathlib.tactic.lint.default
import Mathlib.PostPort

universes u v u_1 u_2 u_3 w

namespace Mathlib

/-!
# Functors

This module provides additional lemmas, definitions, and instances for `functor`s.

## Main definitions

* `const α` is the functor that sends all types to `α`.
* `add_const α` is `const α` but for when `α` has an additive structure.
* `comp F G` for functors `F` and `G` is the functor composition of `F` and `G`.
* `liftp` and `liftr` respectively lift predicates and relations on a type `α`
  to `F α`.  Terms of `F α` are considered to, in some sense, contain values of type `α`.

## Tags

functor, applicative
-/

theorem functor.map_id {F : Type u → Type v} {α : Type u} [Functor F] [is_lawful_functor F] : Functor.map id = id :=
  funext id_map

theorem functor.map_comp_map {F : Type u → Type v} {α : Type u} {β : Type u} {γ : Type u} [Functor F] [is_lawful_functor F] (f : α → β) (g : β → γ) : Functor.map g ∘ Functor.map f = Functor.map (g ∘ f) := sorry

theorem functor.ext {F : Type u_1 → Type u_2} {F1 : Functor F} {F2 : Functor F} [is_lawful_functor F] [is_lawful_functor F] (H : ∀ (α β : Type u_1) (f : α → β) (x : F α), f <$> x = f <$> x) : F1 = F2 := sorry

/-- Introduce the `id` functor. Incidentally, this is `pure` for
`id` as a `monad` and as an `applicative` functor. -/
def id.mk {α : Sort u} : α → id α :=
  id

namespace functor

/-- `const α` is the constant functor, mapping every type to `α`. When
`α` has a monoid structure, `const α` has an `applicative` instance.
(If `α` has an additive monoid structure, see `functor.add_const`.) -/
def const (α : Type u_1) (β : Type u_2) :=
  α

/-- `const.mk` is the canonical map `α → const α β` (the identity), and
it can be used as a pattern to extract this value. -/
def const.mk {α : Type u_1} {β : Type u_2} (x : α) : const α β :=
  x

/-- `const.mk'` is `const.mk` but specialized to map `α` to
`const α punit`, where `punit` is the terminal object in `Type*`. -/
def const.mk' {α : Type u_1} (x : α) : const α PUnit :=
  x

/-- Extract the element of `α` from the `const` functor. -/
def const.run {α : Type u_1} {β : Type u_2} (x : const α β) : α :=
  x

namespace const

protected theorem ext {α : Type u_1} {β : Type u_2} {x : const α β} {y : const α β} (h : run x = run y) : x = y :=
  h

/-- The map operation of the `const γ` functor. -/
protected def map {γ : Type u_1} {α : Type u_2} {β : Type u_3} (f : α → β) (x : const γ β) : const γ α :=
  x

protected instance functor {γ : Type u_1} : Functor (const γ) :=
  { map := const.map, mapConst := fun (α β : Type u_2) => const.map ∘ function.const β }

protected instance is_lawful_functor {γ : Type u_1} : is_lawful_functor (const γ) :=
  is_lawful_functor.mk (fun (α : Type u_2) (x : const γ α) => Eq.refl (id <$> x))
    fun (α β γ_1 : Type u_2) (g : α → β) (h : β → γ_1) (x : const γ α) => Eq.refl ((h ∘ g) <$> x)

protected instance inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] : Inhabited (const α β) :=
  { default := Inhabited.default }

end const

/-- `add_const α` is a synonym for constant functor `const α`, mapping
every type to `α`. When `α` has a additive monoid structure,
`add_const α` has an `applicative` instance. (If `α` has a
multiplicative monoid structure, see `functor.const`.) -/
def add_const (α : Type u_1) (β : Type u_2) :=
  const α

/-- `add_const.mk` is the canonical map `α → add_const α β`, which is the identity,
where `add_const α β = const α β`. It can be used as a pattern to extract this value. -/
def add_const.mk {α : Type u_1} {β : Type u_2} (x : α) : add_const α β :=
  x

/-- Extract the element of `α` from the constant functor. -/
def add_const.run {α : Type u_1} {β : Type u_2} : add_const α β → α :=
  id

protected instance add_const.functor {γ : Type u_1} : Functor (add_const γ) :=
  const.functor

protected instance add_const.is_lawful_functor {γ : Type u_1} : is_lawful_functor (add_const γ) :=
  const.is_lawful_functor

protected instance add_const.inhabited {α : Type u_1} {β : Type u_2} [Inhabited α] : Inhabited (add_const α β) :=
  { default := Inhabited.default }

/-- `functor.comp` is a wrapper around `function.comp` for types.
    It prevents Lean's type class resolution mechanism from trying
    a `functor (comp F id)` when `functor F` would do. -/
def comp (F : Type u → Type w) (G : Type v → Type u) (α : Type v) :=
  F (G α)

/-- Construct a term of `comp F G α` from a term of `F (G α)`, which is the same type.
Can be used as a pattern to extract a term of `F (G α)`. -/
def comp.mk {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : F (G α)) : comp F G α :=
  x

/-- Extract a term of `F (G α)` from a term of `comp F G α`, which is the same type. -/
def comp.run {F : Type u → Type w} {G : Type v → Type u} {α : Type v} (x : comp F G α) : F (G α) :=
  x

namespace comp

protected theorem ext {F : Type u → Type w} {G : Type v → Type u} {α : Type v} {x : comp F G α} {y : comp F G α} : run x = run y → x = y :=
  id

protected instance inhabited {F : Type u → Type w} {G : Type v → Type u} {α : Type v} [Inhabited (F (G α))] : Inhabited (comp F G α) :=
  { default := Inhabited.default }

/-- The map operation for the composition `comp F G` of functors `F` and `G`. -/
protected def map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) : comp F G α → comp F G β :=
  sorry

protected instance functor {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] : Functor (comp F G) :=
  { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β }

theorem map_mk {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) (x : F (G α)) : h <$> mk x = mk (Functor.map h <$> x) :=
  rfl

@[simp] protected theorem run_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] {α : Type v} {β : Type v} (h : α → β) (x : comp F G α) : run (h <$> x) = Functor.map h <$> run x :=
  rfl

protected theorem id_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] {α : Type v} (x : comp F G α) : comp.map id x = x := sorry

protected theorem comp_map {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] {α : Type v} {β : Type v} {γ : Type v} (g' : α → β) (h : β → γ) (x : comp F G α) : comp.map (h ∘ g') x = comp.map h (comp.map g' x) := sorry

protected instance is_lawful_functor {F : Type u → Type w} {G : Type v → Type u} [Functor F] [Functor G] [is_lawful_functor F] [is_lawful_functor G] : is_lawful_functor (comp F G) :=
  is_lawful_functor.mk comp.id_map comp.comp_map

theorem functor_comp_id {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] : comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

theorem functor_id_comp {F : Type u_1 → Type u_2} [AF : Functor F] [is_lawful_functor F] : comp.functor = AF :=
  ext fun (α β : Type u_1) (f : α → β) (x : F α) => rfl

end comp

namespace comp

/-- The `<*>` operation for the composition of applicative functors. -/
protected def seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] {α : Type v} {β : Type v} : comp F G (α → β) → comp F G α → comp F G β :=
  sorry

protected instance has_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Pure (comp F G) :=
  { pure := fun (_x : Type v) (x : _x) => mk (pure (pure x)) }

protected instance has_seq {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Seq (comp F G) :=
  { seq := fun (_x _x_1 : Type v) (f : comp F G (_x → _x_1)) (x : comp F G _x) => comp.seq f x }

@[simp] protected theorem run_pure {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] {α : Type v} (x : α) : run (pure x) = pure (pure x) :=
  idRhs (run (pure x) = run (pure x)) rfl

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

protected instance applicative {F : Type u → Type w} {G : Type v → Type u} [Applicative F] [Applicative G] : Applicative (comp F G) :=
  { toFunctor := { map := comp.map, mapConst := fun (α β : Type v) => comp.map ∘ function.const β },
    toPure := { pure := pure }, toSeq := { seq := comp.seq },
    toSeqLeft :=
      { seqLeft := fun (α β : Type v) (a : comp F G α) (b : comp F G β) => comp.seq (comp.map (function.const β) a) b },
    toSeqRight :=
      { seqRight :=
          fun (α β : Type v) (a : comp F G α) (b : comp F G β) => comp.seq (comp.map (function.const α id) a) b } }

end comp

/-- If we consider `x : F α` to, in some sense, contain values of type `α`,
predicate `liftp p x` holds iff every value contained by `x` satisfies `p`. -/
def liftp {F : Type u → Type u} [Functor F] {α : Type u} (p : α → Prop) (x : F α) :=
  ∃ (u : F (Subtype p)), subtype.val <$> u = x

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`liftr r x y` relates `x` and `y` iff (1) `x` and `y` have the same shape and
(2) we can pair values `a` from `x` and `b` from `y` so that `r a b` holds. -/
def liftr {F : Type u → Type u} [Functor F] {α : Type u} (r : α → α → Prop) (x : F α) (y : F α) :=
  ∃ (u : F (Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p))),
    (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) => prod.fst (subtype.val t)) <$> u = x ∧
      (fun (t : Subtype fun (p : α × α) => r (prod.fst p) (prod.snd p)) => prod.snd (subtype.val t)) <$> u = y

/-- If we consider `x : F α` to, in some sense, contain values of type `α`, then
`supp x` is the set of values of type `α` that `x` contains. -/
def supp {F : Type u → Type u} [Functor F] {α : Type u} (x : F α) : set α :=
  set_of fun (y : α) => ∀ {p : α → Prop}, liftp p x → p y

theorem of_mem_supp {F : Type u → Type u} [Functor F] {α : Type u} {x : F α} {p : α → Prop} (h : liftp p x) (y : α) (H : y ∈ supp x) : p y :=
  hy h

end functor

namespace ulift

protected instance functor : Functor ulift :=
  { map := fun (α β : Type u_1) (f : α → β) => up ∘ f ∘ down,
    mapConst := fun (α β : Type u_1) => (fun (f : β → α) => up ∘ f ∘ down) ∘ function.const β }


/-
Copyright (c) 2022 Devon Tuma. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Devon Tuma
-/
import computational_monads.simulation_semantics.constructions.logging.query_log.basic

/-!
# Forking Operations for Query Logs

This file defines functions for forking a `query_log`, in the sense of removing
all queries after some specified query, leaving the ones before that as is.
-/

namespace query_log

variables {spec : oracle_spec} (log : query_log spec)

section fork_cache

/-- Remove parts of the cache after the query chosen to fork on.
Just wraps a call to `drop_at_index`, dropping everything if the input is `none`.
The result contains exactly the back `i` elements. The choice to drop everything given a `none`
input is just convention, but simplifies some proofs. -/
def fork_cache (log : query_log spec)
  (i : spec.ι) (n : option ℕ) : query_log spec :=
match n with
| none := query_log.init spec
| (some m) := log.drop_at_index i ((log i).length - m) -- The front values are most recent??
end

@[simp] lemma fork_cache_init (i : spec.ι) (n : option ℕ) :
  (query_log.init spec).fork_cache i n = query_log.init spec :=
begin
  induction n with n,
  { exact rfl },
  { exact drop_at_index_init _ i }
end

@[simp] lemma fork_cache_none (i : spec.ι) (log : query_log spec) :
  log.fork_cache i none = query_log.init spec := rfl

end fork_cache

section to_seed

/-- Wrapping function that just reverses every list in the given `query_log`.
  Intended to turn a log into something that can be used as a seed for a computation.
  Needed because the logging function adds the new queries to the front of the list  -/
def to_seed (log : query_log spec) :
  query_log spec :=
λ i, (log i).reverse

@[simp]
lemma to_seed_apply (log : query_log spec) (i : spec.ι) :
  log.to_seed i = (log i).reverse :=
rfl

@[simp]
lemma to_seed_init (spec : oracle_spec) :
  (init spec).to_seed = init spec :=
rfl

lemma to_seed_log_query (log : query_log spec)
  (i : spec.ι) (t : spec.domain i) (u : spec.range i) :
  (log.log_query i t u).to_seed = λ j, if hi : i = j
    then log.to_seed j ++ [hi.rec_on (t, u)] else log.to_seed j :=
begin
  refine ext (λ j, _),
  split_ifs,
  { induction h,
    exact trans (congr_arg list.reverse $ log.log_query_apply_same_index i t u)
      (list.reverse_cons (t, u) (log i)) },
  { exact congr_arg list.reverse (log.log_query_apply_of_index_ne h t u) }
end

end to_seed

end query_log


/-
Copyright (c) 2019 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau

Instances on punit.
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.basic
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

namespace punit

protected instance comm_group : comm_group PUnit :=
  comm_group.mk (fun (_x _x : PUnit) => PUnit.unit) sorry PUnit.unit sorry sorry (fun (_x : PUnit) => PUnit.unit)
    (fun (_x _x : PUnit) => PUnit.unit) sorry sorry

protected instance comm_ring : comm_ring PUnit :=
  comm_ring.mk add_comm_group.add add_comm_group.add_assoc add_comm_group.zero add_comm_group.zero_add
    add_comm_group.add_zero add_comm_group.neg add_comm_group.sub add_comm_group.add_left_neg add_comm_group.add_comm
    comm_group.mul comm_group.mul_assoc comm_group.one comm_group.one_mul comm_group.mul_one sorry sorry
    comm_group.mul_comm

protected instance complete_boolean_algebra : complete_boolean_algebra PUnit :=
  complete_boolean_algebra.mk (fun (_x _x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => True)
    (fun (_x _x : PUnit) => False) sorry sorry sorry sorry sorry sorry (fun (_x _x : PUnit) => PUnit.unit) sorry sorry
    sorry sorry PUnit.unit sorry PUnit.unit sorry (fun (_x : PUnit) => PUnit.unit) (fun (_x _x : PUnit) => PUnit.unit)
    sorry sorry sorry (fun (_x : set PUnit) => PUnit.unit) (fun (_x : set PUnit) => PUnit.unit) sorry sorry sorry sorry
    sorry sorry

protected instance canonically_ordered_add_monoid : canonically_ordered_add_monoid PUnit :=
  canonically_ordered_add_monoid.mk comm_ring.add comm_ring.add_assoc comm_ring.zero comm_ring.zero_add comm_ring.add_zero
    comm_ring.add_comm complete_boolean_algebra.le complete_boolean_algebra.lt complete_boolean_algebra.le_refl
    complete_boolean_algebra.le_trans complete_boolean_algebra.le_antisymm sorry sorry complete_boolean_algebra.bot
    complete_boolean_algebra.bot_le sorry

protected instance linear_ordered_cancel_add_comm_monoid : linear_ordered_cancel_add_comm_monoid PUnit :=
  linear_ordered_cancel_add_comm_monoid.mk canonically_ordered_add_monoid.add canonically_ordered_add_monoid.add_assoc
    sorry canonically_ordered_add_monoid.zero canonically_ordered_add_monoid.zero_add
    canonically_ordered_add_monoid.add_zero canonically_ordered_add_monoid.add_comm sorry
    canonically_ordered_add_monoid.le canonically_ordered_add_monoid.lt canonically_ordered_add_monoid.le_refl
    canonically_ordered_add_monoid.le_trans canonically_ordered_add_monoid.le_antisymm
    canonically_ordered_add_monoid.add_le_add_left sorry sorry (fun (_x _x : PUnit) => decidable.true) punit.decidable_eq
    fun (_x _x : PUnit) => decidable.false

protected instance semimodule (R : Type u) [semiring R] : semimodule R PUnit :=
  semimodule.of_core (semimodule.core.mk (has_scalar.mk fun (_x : R) (_x : PUnit) => PUnit.unit) sorry sorry sorry sorry)

@[simp] theorem zero_eq : 0 = PUnit.unit :=
  rfl

@[simp] theorem one_eq : 1 = PUnit.unit :=
  rfl

@[simp] theorem add_eq (x : PUnit) (y : PUnit) : x + y = PUnit.unit :=
  rfl

@[simp] theorem mul_eq (x : PUnit) (y : PUnit) : x * y = PUnit.unit :=
  rfl

@[simp] theorem sub_eq (x : PUnit) (y : PUnit) : x - y = PUnit.unit :=
  rfl

@[simp] theorem neg_eq (x : PUnit) : -x = PUnit.unit :=
  rfl

@[simp] theorem inv_eq (x : PUnit) : x⁻¹ = PUnit.unit :=
  rfl

theorem smul_eq (x : PUnit) (y : PUnit) : x • y = PUnit.unit :=
  rfl

@[simp] theorem top_eq : ⊤ = PUnit.unit :=
  rfl

@[simp] theorem bot_eq : ⊥ = PUnit.unit :=
  rfl

@[simp] theorem sup_eq (x : PUnit) (y : PUnit) : x ⊔ y = PUnit.unit :=
  rfl

@[simp] theorem inf_eq (x : PUnit) (y : PUnit) : x ⊓ y = PUnit.unit :=
  rfl

@[simp] theorem Sup_eq (s : set PUnit) : Sup s = PUnit.unit :=
  rfl

@[simp] theorem Inf_eq (s : set PUnit) : Inf s = PUnit.unit :=
  rfl

@[simp] protected theorem le (x : PUnit) (y : PUnit) : x ≤ y :=
  trivial

@[simp] theorem not_lt (x : PUnit) (y : PUnit) : ¬x < y :=
  not_false


import for_mathlib.coprod.free_group_subgroup
import .functor
import neat.cyclically_reduce
import neat.initial
import tactic

noncomputable theory

notation `C∞` := multiplicative ℤ

universe u

variables {ι : Type} [decidable_eq ι] (r : free_group ι) (T : set ι) [decidable_pred T]

open free_group P semidirect_product multiplicative

def mul_subscript : C∞ →* free_group (ι × C∞) ≃* free_group (ι × C∞) :=
{ to_fun := λ n, free_group.equiv (equiv.prod_congr (equiv.refl _) (mul_left n)),
  map_one' := sorry,
  map_mul' := sorry }

def add_subscript (t : ι) : free_group ι →* free_group (ι × C∞) ⋊[mul_subscript] C∞ :=
free_group.lift' (λ j,
  if t = j
  then semidirect_product.inr
  else semidirect_product.inl.comp (of' (j, 1)))

def remove_subscript (t : ι) : free_group (ι × C∞) →* free_group ι :=
free_group.lift' (λ g, (mul_aut.conj (of' t g.2)).to_monoid_hom.comp (of' g.1))

@[simp] lemma remove_subscript_comp_mul_subscript (t : ι) (n : C∞) :
  (remove_subscript t).comp (@mul_subscript ι _ n).to_monoid_hom =
  (mul_aut.conj (of' t n)).to_monoid_hom.comp (remove_subscript t) :=
free_group.hom_ext
  (by simp [remove_subscript, mul_subscript, lift'_eq_lift, of'_eq_of_pow, gpow_add, mul_assoc])

@[simp] lemma remove_subscript_mul_subscript (t : ι) (n : C∞) (x) : remove_subscript t
  (mul_subscript n x) =  of' t n * remove_subscript t x * of' t n⁻¹ :=
by simpa [-remove_subscript_comp_mul_subscript] using monoid_hom.ext_iff.1
  (remove_subscript_comp_mul_subscript t n) x

@[simp] lemma remove_subscript_mul_subscript_inv (t : ι) (n : C∞) (x) : remove_subscript t
  ((mul_subscript n)⁻¹ x) = of' t n⁻¹ * remove_subscript t x * of' t n :=
by rw [← monoid_hom.map_inv, remove_subscript_mul_subscript, inv_inv, mul_assoc]

@[simp] lemma remove_subscript_of' (t : ι) (l : ι × C∞) (n : C∞) : remove_subscript t (of' l n) =
  (mul_aut.conj (of' t l.2)) (of' l.1 n) :=
free_group.lift'_of' _ _ _

def remove_subscript_SD (t : ι) : free_group (ι ×C∞) ⋊[mul_subscript] C∞ →* free_group ι :=
semidirect_product.lift (remove_subscript t) (of' t)
  (λ g, hom_ext (λ j, by simp [mul_aut.conj_apply, mul_assoc]))

include r

lemma lhs_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : P (free_group ι)}
  (h : y ∈ n x) : lhs r y = x := sorry

lemma lhs_inl_eq_of_mem {n : solver r T}
  {x : free_group ι} {y : P (free_group ι)}
  (h : y ∈ n x) : lhs r (inl y.left) = x * y.right⁻¹ :=
by rw [eq_mul_inv_iff_mul_eq, ← lhs_inr y.right, ← monoid_hom.map_mul,
    inl_left_mul_inr_right, lhs_eq_of_mem r T h]

variable {ι}

omit r

noncomputable def normalize_cons
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (old1 : free_group (ι × C∞)) --contains no t
  (old2 : P (free_group (ι × C∞))),
  P (free_group (ι × C∞))
| old1 ⟨w, ⟨[], _⟩⟩     := ⟨mul_free old1 w, old1⟩
| old1 ⟨w, ⟨i :: l, _⟩⟩ :=
  if i.1.1 = t
  then if i.2 ≤ 1
    then option.elim (hA old1)
      (inr old1 * ⟨w, ⟨i :: l, sorry⟩⟩)
      (λ a, inr (of (t, 1))⁻¹ *
        normalize_cons (mul_subscript (of_add 1) (right_hom a))
          ⟨mul_free (of (t, 1)) (mul_free a.right⁻¹ a.left * w),
            of' (t, 1) (of_add 1 * i.2) * ⟨l, sorry⟩⟩)
    else option.elim (hB old1)
      (inr old1 * ⟨w, ⟨i :: l, sorry⟩⟩)
      (λ a, inr (of (t, 1)) *
        normalize_cons (mul_subscript (of_add (-1)) (right_hom a))
          ⟨mul_free (of (t, 1))⁻¹ (mul_free a.right⁻¹ a.left * w), of' i.1 (of_add (-1) * i.2) *⟨l, sorry⟩⟩)
  else normalize_cons ⟨old1.1 ++ [i], sorry⟩ ⟨(mul_free (of' i.1 i.2))⁻¹ w, ⟨l, sorry⟩⟩
using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

set_option timeout 10000000

-- @[simp] lemma remove_subscript_lhs_normalize_cons
--   (t : ι) (r' : free_group (ι × C∞))
--   {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A)
--   (hB : solver r' B) :
--   Π (old1 : free_group (ι × C∞))
--   (old2 : P (free_group (ι × C∞))),
--   remove_subscript t (lhs r' (normalize_cons t r' hA hB old1 old2)) =
--     remove_subscript t (old1 * lhs r' old2)
-- | old1 ⟨w, ⟨[], _⟩⟩     := by rw normalize_cons; simp [inl_aut]
-- | old1 ⟨w, ⟨i :: l, _⟩⟩ := begin
--   rw [normalize_cons],
--   split_ifs,
--   { cases h1 : hA old1,
--     { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
--     { have : i.1.2 = of_add 1, from sorry,
--       simp [remove_subscript_lhs_normalize_cons, mul_assoc, inl_aut_inv,
--         lhs_inl_eq_of_mem _ _ h1, inl_aut, this, h, of_eq_of',
--         lhs_eq_of_mem _ _ h1], } },
--   { cases h2 : hB old1,
--     { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
--     { have : i.1.2 = of_add 1, from sorry,
--       simp [remove_subscript_lhs_normalize_cons, mul_assoc, inl_aut_inv,
--         lhs_inl_eq_of_mem _ _ h2, inl_aut, this, h, of_eq_of',
--         lhs_eq_of_mem _ _ h2] } },
--   { simp [remove_subscript_lhs_normalize_cons, inl_aut_inv, mul_assoc] },
-- end
-- using_well_founded { rel_tac := λ _ _, `[exact ⟨λ _ _, true, sorry⟩], dec_tac := `[trivial] }

noncomputable def normalize_with_subscript_aux
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B) :
  Π (w : list (Σ i : ι, C∞)) (hw : coprod.pre.reduced w),
  P (free_group (ι × C∞))
| []       _ := 1
| (i :: l) h := normalize_cons t r' hA hB (of' (i.1, 1) i.2)
  (normalize_with_subscript_aux l (coprod.pre.reduced_of_reduced_cons h))

noncomputable def normalize_with_subscript
  (t : ι) (r' : free_group (ι × C∞))
  {A B : set (ι × C∞)}
  [decidable_pred A] [decidable_pred B]
  (hA : solver r' A) (hB : solver r' B)
  (w : free_group ι) :
  P (free_group (ι × C∞)) :=
normalize_with_subscript_aux t r' hA hB w.1 w.2

-- lemma remove_subscript_lhs_normalize_with_subscript_aux
--   (t : ι) (r' : free_group (ι × C∞))
--   {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A) (hB : solver r' B) :
--   Π (w : list (Σ i : ι, C∞)) (hw : coprod.pre.reduced w),
--   remove_subscript t (lhs r' (normalize_with_subscript_aux t r' hA hB w hw)) = ⟨w, hw⟩
-- | []       _ := by simp [normalize_with_subscript_aux]
-- | (i :: l) _ := begin
--   rw [normalize_with_subscript_aux, remove_subscript_lhs_normalize_cons,
--     monoid_hom.map_mul, remove_subscript_lhs_normalize_with_subscript_aux],
--   simp
-- end

-- @[simp] lemma remove_subscript_lhs_normalize_with_subscript
--   (t : ι) (r' : free_group (ι × C∞)) {A B : set (ι × C∞)}
--   [decidable_pred A] [decidable_pred B]
--   (hA : solver r' A) (hB : solver r' B) (w : free_group ι) :
--   remove_subscript t (lhs r' (normalize_with_subscript t r' hA hB w)) = w :=
-- by cases w; apply remove_subscript_lhs_normalize_with_subscript_aux

-- def exp_sum_eq_zero (t x : ι)
--   (hs : Π (r : free_group (ι × C∞)) (T : set (ι × C∞)) [decidable_pred T], solver r T)
--   (cyc_r : free_group ι):
--   solver cyc_r T := λ w,
-- let (c₂, conj_r) := cyclically_conjugate x cyc_r in
-- let r' := (add_subscript t conj_r).left in
-- let (a, b) := min_max_subscript x r' in
-- let p := normalize_with_subscript t r'
--   (hs r' (Icc_prod x a (b * (of_add 1)⁻¹)))
--   (hs r' (Icc_prod x (a * of_add 1) b))
--   w in
-- let T' : set (ι × C∞) :=
--   if t ∈ T
--     then { i : ι × C∞ | i.1 ∈ T }
--     else { i : ι × C∞ | i.1 ∈ T ∧ i.2 = 1 } in
-- let dT' : decidable_pred T' := by dsimp [T']; split_ifs; apply_instance in
-- do np ← @hs r' T' dT' p.right,
-- return (change_r (c₂⁻¹) (P.map (remove_subscript t) sorry (P.trans p np)))


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

/-!
# The category of bounded distributive lattices

This defines `BoundedDistribLattice`, the category of bounded distributive lattices.

Note that this category is sometimes called [`DistLat`][https://ncatlab.org/nlab/show/DistLat] when
being a lattice is understood to entail having a bottom and a top element.
-/

universes u

open category_theory

/-- The category of bounded distributive lattices with bounded lattice morphisms. -/
structure BoundedDistribLattice :=
(to_DistribLattice : DistribLattice)
[is_bounded_order : bounded_order to_DistribLattice]

namespace BoundedDistribLattice

instance : has_coe_to_sort BoundedDistribLattice Type* := ⟨λ X, X.to_DistribLattice⟩
instance (X : BoundedDistribLattice) : distrib_lattice X := X.to_DistribLattice.str

attribute [instance] BoundedDistribLattice.is_bounded_order

/-- Construct a bundled `BoundedDistribLattice` from a `bounded_order` `distrib_lattice`. -/
def of (α : Type*) [distrib_lattice α] [bounded_order α] : BoundedDistribLattice := ⟨⟨α⟩⟩

@[simp] lemma coe_of (α : Type*) [distrib_lattice α] [bounded_order α] : ↥(of α) = α := rfl

instance : inhabited BoundedDistribLattice := ⟨of punit⟩

/-- Turn a `BoundedDistribLattice` into a `BoundedLattice` by forgetting it is distributive. -/
def to_BoundedLattice (X : BoundedDistribLattice) : BoundedLattice := BoundedLattice.of X

@[simp] lemma coe_to_BoundedLattice (X : BoundedDistribLattice) : ↥X.to_BoundedLattice = ↥X := rfl

instance : large_category.{u} BoundedDistribLattice := induced_category.category to_BoundedLattice

instance : concrete_category BoundedDistribLattice :=
induced_category.concrete_category to_BoundedLattice

instance has_forget_to_DistribLattice : has_forget₂ BoundedDistribLattice DistribLattice :=
{ forget₂ := { obj := λ X, ⟨X⟩, map := λ X Y, bounded_lattice_hom.to_lattice_hom } }

instance has_forget_to_BoundedLattice : has_forget₂ BoundedDistribLattice BoundedLattice :=
induced_category.has_forget₂ to_BoundedLattice

lemma forget_BoundedLattice_Lattice_eq_forget_DistribLattice_Lattice :
  forget₂ BoundedDistribLattice BoundedLattice ⋙ forget₂ BoundedLattice Lattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ forget₂ DistribLattice Lattice := rfl

/-- Constructs an equivalence between bounded distributive lattices from an order isomorphism
between them. -/
@[simps] def iso.mk {α β : BoundedDistribLattice.{u}} (e : α ≃o β) : α ≅ β :=
{ hom := (e : bounded_lattice_hom α β),
  inv := (e.symm : bounded_lattice_hom β α),
  hom_inv_id' := by { ext, exact e.symm_apply_apply _ },
  inv_hom_id' := by { ext, exact e.apply_symm_apply _ } }

/-- `order_dual` as a functor. -/
@[simps] def dual : BoundedDistribLattice ⥤ BoundedDistribLattice :=
{ obj := λ X, of (order_dual X), map := λ X Y, bounded_lattice_hom.dual }

/-- The equivalence between `BoundedDistribLattice` and itself induced by `order_dual` both ways. -/
@[simps functor inverse] def dual_equiv : BoundedDistribLattice ≌ BoundedDistribLattice :=
equivalence.mk dual dual
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)
  (nat_iso.of_components (λ X, iso.mk $ order_iso.dual_dual X) $ λ X Y f, rfl)

end BoundedDistribLattice

lemma BoundedDistribLattice_dual_comp_forget_to_DistribLattice :
  BoundedDistribLattice.dual ⋙ forget₂ BoundedDistribLattice DistribLattice =
    forget₂ BoundedDistribLattice DistribLattice ⋙ DistribLattice.dual := rfl