/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.erase_dup
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# The fold operation for a commutative associative operation over a multiset.
-/

namespace multiset

/-! ### fold -/

/-- `fold op b s` folds a commutative associative operation `op` over
  the multiset `s`. -/
def fold {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] : α → multiset α → α :=
  foldr op sorry

theorem fold_eq_foldr {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (s : multiset α) : fold op b s = foldr op (left_comm op is_commutative.comm is_associative.assoc) b s :=
  rfl

@[simp] theorem coe_fold_r {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldr op b l :=
  rfl

theorem coe_fold_l {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (l : List α) : fold op b ↑l = list.foldl op b l := sorry

theorem fold_eq_foldl {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (s : multiset α) : fold op b s = foldl op (right_comm op is_commutative.comm is_associative.assoc) b s :=
  quot.induction_on s fun (l : List α) => coe_fold_l op b l

@[simp] theorem fold_zero {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) : fold op b 0 = b :=
  rfl

@[simp] theorem fold_cons_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = op a (fold op b s) :=
  foldr_cons op (fold._proof_1 op)

theorem fold_cons_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = op (fold op b s) a := sorry

theorem fold_cons'_right {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = fold op (op b a) s := sorry

theorem fold_cons'_left {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) (s : multiset α) : fold op b (a ::ₘ s) = fold op (op a b) s :=
  eq.mpr (id (Eq._oldrec (Eq.refl (fold op b (a ::ₘ s) = fold op (op a b) s)) (fold_cons'_right op b a s)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (fold op (op b a) s = fold op (op a b) s)) (is_commutative.comm b a)))
      (Eq.refl (fold op (op a b) s)))

theorem fold_add {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b₁ : α) (b₂ : α) (s₁ : multiset α) (s₂ : multiset α) : fold op (op b₁ b₂) (s₁ + s₂) = op (fold op b₁ s₁) (fold op b₂ s₂) := sorry

theorem fold_singleton {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] (b : α) (a : α) : fold op b (a ::ₘ 0) = op a b := sorry

theorem fold_distrib {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] {f : β → α} {g : β → α} (u₁ : α) (u₂ : α) (s : multiset β) : fold op (op u₁ u₂) (map (fun (x : β) => op (f x) (g x)) s) = op (fold op u₁ (map f s)) (fold op u₂ (map g s)) := sorry

theorem fold_hom {α : Type u_1} {β : Type u_2} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] {op' : β → β → β} [is_commutative β op'] [is_associative β op'] {m : α → β} (hm : ∀ (x y : α), m (op x y) = op' (m x) (m y)) (b : α) (s : multiset α) : fold op' (m b) (map m s) = m (fold op b s) := sorry

theorem fold_union_inter {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) (b₁ : α) (b₂ : α) : op (fold op b₁ (s₁ ∪ s₂)) (fold op b₂ (s₁ ∩ s₂)) = op (fold op b₁ s₁) (fold op b₂ s₂) := sorry

@[simp] theorem fold_erase_dup_idem {α : Type u_1} (op : α → α → α) [hc : is_commutative α op] [ha : is_associative α op] [DecidableEq α] [hi : is_idempotent α op] (s : multiset α) (b : α) : fold op b (erase_dup s) = fold op b s := sorry

theorem le_smul_erase_dup {α : Type u_1} [DecidableEq α] (s : multiset α) : ∃ (n : ℕ), s ≤ n •ℕ erase_dup s := sorry


import for_mathlib.homological_complex_op
import for_mathlib.homotopy_category

noncomputable theory

open opposite category_theory category_theory.limits

variables {ι : Type*} (c : complex_shape ι)

namespace complex_shape

@[simp]
lemma symm_next (i : ι) : c.symm.next i = c.prev i := rfl

@[simp]
lemma symm_prev (i : ι) : c.symm.prev i = c.next i := rfl

end complex_shape

namespace homological_complex

lemma op_functor_map_homotopy {ι C : Type*} {c : complex_shape ι} [category C] [preadditive C]
  {X Y : homological_complex C c}
  (f₁ f₂ : X ⟶ Y) (H : homotopy f₁ f₂) :
  homotopy
    (homological_complex.op_functor.map f₁.op)
    (homological_complex.op_functor.map f₂.op) :=
{ hom := λ i j, (H.hom j i).op,
  zero' := λ i j hij, by rw [H.zero j i hij, op_zero],
  comm := λ i, begin
    simp only [homological_complex.op_functor_map_f, quiver.hom.unop_op, H.comm i,
      op_add, add_left_inj],
    conv_lhs { rw add_comm, },
    congr' 1,
    { rcases hi : c.prev i with _ | ⟨j, hj⟩,
      { dsimp [prev_d, d_next],
        simpa only [hi], },
      { have hj' : c.symm.rel i j := hj,
        simpa only [prev_d_eq _ hj, d_next_eq _ hj'], }, },
    { rcases hi : c.next i with _ | ⟨j, hj⟩,
      { dsimp [prev_d, d_next],
        simpa only [hi], },
      { have hj' : c.symm.rel j i := hj,
        simpa only [d_next_eq _ hj, prev_d_eq _ hj'], }, },
  end, }

end homological_complex

namespace homotopy_category

variables {C : Type*} [category C] [preadditive C] {c}

def op_functor : (homotopy_category C c)ᵒᵖ ⥤ homotopy_category Cᵒᵖ c.symm :=
functor.left_op (category_theory.quotient.lift _
  (homological_complex.op_functor ⋙ homotopy_category.quotient Cᵒᵖ c.symm).right_op
(λ X Y f₁ f₂ h, begin
  dsimp only [functor.right_op],
  congr' 1,
  dsimp only [functor.comp_map],
  erw quotient.functor_map_eq_iff,
  refine ⟨homological_complex.op_functor_map_homotopy f₁ f₂ h.some⟩,
end))

def quotient_op_functor :
  (quotient C c).op ⋙ op_functor ≅ homological_complex.op_functor ⋙ quotient Cᵒᵖ c.symm :=
nat_iso.of_components (λ X, eq_to_iso (by refl))
(λ X Y f, by { dsimp, simpa only [category.comp_id, category.id_comp], })

def unop_functor : (homotopy_category Cᵒᵖ c)ᵒᵖ ⥤ homotopy_category C c.symm :=
functor.left_op (category_theory.quotient.lift _
  (homological_complex.unop_functor ⋙ homotopy_category.quotient C c.symm).right_op
(λ X Y f₁ f₂ h, begin
  dsimp only [functor.right_op],
  congr' 1,
  dsimp only [functor.comp_map],
  erw quotient.functor_map_eq_iff,
  let H := h.some,
  exact nonempty.intro
  { hom := λ i j, (H.hom j i).unop,
    zero' := λ i j hij, by rw [H.zero j i hij, unop_zero],
    comm := λ i, begin
      apply quiver.hom.op_inj,
      simp only [homological_complex.unop_functor_map_f, op_add, quiver.hom.op_unop,
        quiver.hom.unop_op, H.comm i],
      conv_lhs { congr, rw add_comm, },
      congr' 2,
      { rcases hi : c.prev i with _ | ⟨j, hj⟩,
        { dsimp [prev_d, d_next],
          simpa only [hi], },
        { have hj' : c.symm.rel i j := hj,
          simpa only [prev_d_eq _ hj, d_next_eq _ hj'], }, },
      { rcases hi : c.next i with _ | ⟨j, hj⟩,
        { dsimp [prev_d, d_next],
          simpa only [hi], },
        { have hj' : c.symm.rel j i := hj,
          simpa only [d_next_eq _ hj, prev_d_eq _ hj'], }, },
    end, },
end))

def quotient_unop_functor :
  (quotient Cᵒᵖ c).op ⋙ unop_functor ≅ homological_complex.unop_functor ⋙ quotient C c.symm :=
nat_iso.of_components (λ X, eq_to_iso (by refl))
(λ X Y f, by { dsimp, simpa only [category.comp_id, category.id_comp], })

end homotopy_category


import Lib.Tactic

inductive EqvGen (R : α → α → Prop) : α → α → Prop :=
| rfl {x} : EqvGen R x x
| step {x y z} : R x y → EqvGen R y z → EqvGen R x z
| symm_step {x y z} : R y x → EqvGen R y z → EqvGen R x z

namespace EqvGen

variable {R : α → α → Prop}

theorem once (h : R x y) : EqvGen R x y := EqvGen.step h EqvGen.rfl
theorem once_symm (h : R y x) : EqvGen R x y := EqvGen.symm_step h EqvGen.rfl

theorem trans : EqvGen R x y → EqvGen R y z → EqvGen R x z := by
  intros h₀ h₁
  induction h₀ with
  | rfl => exact h₁
  | step hR hGen IH => exact step hR (IH h₁)
  | symm_step hR hGen IH => exact symm_step hR (IH h₁)

theorem symm_step_r : EqvGen R x y → R z y → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once_symm h₁
  apply trans <;> assumption
theorem step_r : EqvGen R x y → R y z → EqvGen R x z := by
  intros h₀ h₁
  have h₁ := once h₁
  apply trans <;> assumption

theorem symm : EqvGen R x y → EqvGen R y x := by
  intros h
  induction h with
  | rfl => exact rfl
  | step hR hGen IH => exact trans IH (symm_step hR rfl)
  | symm_step hR hGen IH => exact trans IH (step hR rfl)

end EqvGen

namespace Quot
variable {r : α → α → Prop}
variable {r' : α' → α' → Prop}

def map (f : α → α') (hf : ∀ x y, r x y → r' (f x) (f y)) : Quot r → Quot r' :=
Quot.lift (λ a => Quot.mk _ (f a)) $ by
  intros; apply Quot.sound; auto

def toQuotEqvGen : Quot r → Quot (EqvGen r) :=
map id $ λ x y => EqvGen.once

def liftOn₂ (x : Quot r) (y : Quot r') (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') : β :=
Quot.liftOn x
  (λ x => Quot.liftOn y (f x) $
    by intros; auto) $
  by intros
     induction y using Quot.inductionOn
     simp [Quot.liftOn]; auto

@[simp]
def liftOn₂_beta {x : α} {y : α'} (f : α → α' → β)
  (h : ∀ (a b : α) (a' : α'),
    r a b → f a a' = f b a')
  (h' : ∀ (a : α) (a' b' : α'),
    r' a' b' → f a a' = f a b') :
liftOn₂ (Quot.mk _ x) (Quot.mk _ y) f h h' = f x y :=
by simp [liftOn₂]

noncomputable def out (x : Quot r) : α :=
Classical.choose (exists_rep x)

theorem eq' : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    have Hlift : ∀ (a b : α), r a b → EqvGen r x a = EqvGen r x b := by
      intros a b Hab
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
    rw [← Quot.liftBeta (r := r) (EqvGen r x) Hlift, ← h,
          Quot.liftBeta (r := r) _ Hlift]
    exact EqvGen.rfl
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

theorem eq : Quot.mk r x = Quot.mk r y ↔ EqvGen r x y := by
  constructor
  focus
    intros h
    rewrite [← liftOn₂_beta (r:=r) (r':=r) (EqvGen r), h, liftOn₂_beta]
    focus
      exact EqvGen.rfl
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.symm_step <;> assumption
      focus apply EqvGen.step <;> assumption
    focus
      intros x y z Hxy
      apply propext
      constructor <;> intro h
      focus apply EqvGen.step_r <;> assumption
      focus apply EqvGen.symm_step_r <;> assumption
  focus
    intros h
    induction h with
    | rfl => refl
    | step Hr Hgen IH =>
      rw [← IH]
      apply Quot.sound; assumption
    | symm_step Hr Hgen IH =>
      apply Eq.symm
      rw [← IH]
      apply Quot.sound; assumption

end Quot

attribute [auto] Quot.sound

def Relation1 (F : Type u → Type v) :=
{{α : Type u}} → F α → F α → Prop

class Relation1.Functorial {F} [Functor F] (R : Relation1 F) where
  rel_map {α β} (x y : F α) (f : α → β) : R x y → R (f <$> x) (f <$> y)

attribute [auto] Relation1.Functorial.rel_map

class Relation1.Applicative {F} [H : Applicative F] (R : Relation1 F)
      extends Relation1.Functorial R where
  refl {α} (x : F α) : R x x
  rel_pure {α : Type u} (x : α) : R (pure x) (pure x)
  rel_seq {α β : Type u} (x y : Unit → F α) (f g : F (α → β)) :
    R f g →
    R (x ()) (y ()) →
    R (Seq.seq f x) (Seq.seq g y)
  rel_map {α β : Type u} (x y : F α) (f : α → β) :=
    λ HR : R x y =>
    suffices R (pure f <*> x) (pure f <*> y) by simp [*]
    rel_seq _ _ _ _ (rel_pure _) HR

instance  {F} [Applicative F] (R : Relation1 F) [Relation1.Applicative R] :
          Reflexive (@R α) where
  refl := Relation1.Applicative.refl

attribute [auto] Relation1.Applicative.rel_pure Relation1.Applicative.rel_seq

def Quot1 {F} (R : Relation1 F) (α : Type u) := Quot (@R α)

namespace Quot1

variable {F : Type u → Type v} (R : Relation1 F)
variable {G : Type u → Type v} (R' : Relation1 G)

@[matchPattern]
def mk {α} (x : F α) : Quot1 R α :=
Quot.mk _ x

variable {R} {R'}

@[recursor 3]
def lift {α β} (f : F α → β) (h : ∀ x y : F α, R x y → f x = f y) : Quot1 R α → β :=
Quot.lift f h

section lift₂

def lift₂ {α β γ} (f : F α → G β → γ)
    (hF : ∀ x y : F α, ∀ z, R x y → f x z = f y z)
    (hG : ∀ x y : G β, ∀ z, R' x y → f z x = f z y) :
  Quot1 R α → Quot1 R' β → γ :=
λ x y =>
Quot.liftOn₂ x y f
  (λ x y z => hF _ _ _)
  (λ x y z => hG _ _ _)

def liftOn₂ {α β γ}
    (x : Quot1 R α) (y : Quot1 R' β)
    (f : F α → G β → γ)
    (hF : ∀ x y : F α, ∀ z, R x y → f x z = f y z)
    (hG : ∀ x y : G β, ∀ z, R' x y → f z x = f z y) : γ :=
lift₂ _ hF hG x y

end lift₂

@[simp]
theorem lift_mk  {α β} (f : F α → β) (x : F α) h :
  lift f h (mk R x) = f x :=
Quot.liftBeta _ h x

@[auto]
theorem sound (x y : F α) : R x y → mk R x = mk R y :=
Quot.sound

theorem ind {α} {β : Quot1 R α → Prop} (f : ∀ x, β (mk R x)) : ∀ x, β x :=
Quot.ind f

section Functorial
variable [Functor F]
variable [R.Functorial]

instance : Functor (Quot1 R) where
  map f := Quot1.lift (Quot1.mk _ ∘ (f <$> .)) $ by auto with 6

end Functorial

section Applicative
variable [Applicative F] [LawfulApplicative F]
variable [R.Applicative]

instance : Applicative (Quot1 R) where
  pure x := Quot1.mk _ (pure x)
  seq f x := Quot1.liftOn₂ f (x ())
    (λ f x => Quot1.mk R (f <*> x))
    ( by auto with 7 )
    ( by auto with 7 )

end Applicative

end Quot1