import .kruskal .higman data.list
open classical fin set nat subtype finite_tree kruskal function prod

noncomputable theory

theorem dne {p : Prop} (H : ¬¬p) : p := or.elim (em p) (assume Hp : p, Hp) (assume Hnp : ¬p, absurd Hnp H)

lemma tag_eq_of_eq {A : Type} {P : A → Prop} {a b : subtype P} (H : a = b) :a.1 = b.1 := by rw H

section

variables {A B : Type}
variable x : A × B

theorem prod_eta : (x.1,x.2) = x := prod.rec_on x (λ a b, rfl)

theorem eq_of_prod {A B : Type} {p q : A × B} (H1 : p.1 = q.1) (H2 : p.2 = q.2) : p = q :=
begin
cases p with p1 p2,
dsimp at H1, dsimp at H2,
rw [H1,H2,prod_eta]
end

end

theorem ne_empty_of_image_on_univ {A B : Type} (f : A → B) [inhabited A] : image f univ ≠ ∅ :=
have (∅ : set A) ≠ univ, from empty_ne_univ,
have ∃ a, a ∈ (univ : set A), from exists_mem_of_ne_empty (ne.symm this),
let ⟨a,h⟩ := this in
have f a ∈ image f univ, from exists.intro a (and.intro h rfl),
set.ne_empty_of_mem this

theorem val_mapsto (n : ℕ) : maps_to fin.val (@univ (fin n)) {i : ℕ | i < n} :=
take x, assume Ha, is_lt x

theorem injective_val_on_univ (n : ℕ): inj_on fin.val (@univ (fin n)) :=
take x₁ x₂, assume H1, assume H2, assume eq, eq_of_veq eq

instance finite_univ_of_fin (n : ℕ) : finite (@univ (fin n)) :=
finite_of_inj_on (val_mapsto n) (injective_val_on_univ n)

theorem refl_of_image_on_univ {A B: Type} (f : A → B) : set.image f (@set.univ A) = {b : B | ∃ x, f x = b} :=
have Hl : set.image f (@set.univ A) ⊆ {b : B | ∃ x, f x = b}, from
  take x, assume Hx,
  let ⟨i,h⟩ := Hx in exists.intro i (and.right h),
have {b : B | ∃ x, f x = b} ⊆ set.image f  (@set.univ A), from
  take x, assume Hx,
  let ⟨i,h⟩ := Hx in exists.intro i (and.intro trivial h),
set.subset.antisymm Hl this

theorem finite_image_of_fin {A : Type} {n : ℕ} (f : fin n → A) : finite {a : A | ∃ x, f x = a} :=
have image f (@univ (fin n)) = {a : A | ∃ x, f x = a}, from refl_of_image_on_univ f,
have finite (image f (@univ (fin n))), from finite_image f (@univ (fin n)),
by super

-- need this to handle trees of the form (f n) where f : ℕ → finite_tree
theorem finite_tree_destruct {t : finite_tree} :
∃ n (ss : fin n → finite_tree), t = cons ss :=
finite_tree.cases_on t (λ n a, ⟨n,a,rfl⟩)

definition num_of_branches_at_root : finite_tree → ℕ
| (@cons n ts) := n

-- definition num_of_branches_at_root (t : finite_tree) (H : t ≠ node) : ℕ :=
-- some (exists_eq_cons_of_ne_node H)

-- definition branches_at_root : finite_tree → Π {n : ℕ}, fin n → finite_tree
-- | (@cons n ts) := ts
-- some (some_spec (exists_eq_cons_of_ne_node H))

-- definition set_of_branches' {n : ℕ} : finite_tree → set (finite_tree × ℕ)
-- | (@cons n ts) := {x : finite_tree × ℕ | ∃ a : fin n, ts a = x.1 ∧ val a = x.2}

-- {x : finite_tree × ℕ | ∃ a : fin n, ts a = x.1 ∧ val a = x.2}

def branches_aux {n : ℕ} (ts : fin n → finite_tree) : set (finite_tree × ℕ) :=
{x : finite_tree × ℕ | ∃ a : fin n, ts a = x.1 ∧ val a = x.2}

theorem empty_branches (ts : fin 0 → finite_tree) : branches_aux ts = ∅ :=
have ∀ x, x ∉ branches_aux ts, from λ x h, let ⟨a,ha⟩ := h in fin_zero_absurd a,
set.eq_empty_of_forall_not_mem this

definition branches : finite_tree → set (finite_tree × ℕ)
| (@cons n ts) := branches_aux ts

theorem embeds_of_branches {t : finite_tree × ℕ} {T : finite_tree} : t ∈ (branches T) → t.1 ≼ T :=
begin
cases T with n ts,
intro H, cases H with a h,
cases t.1 with t1a t1s,
dsimp [embeds],apply or.inl,
fapply exists.intro,
exact a, rw h^.left, apply embeds_refl
end

theorem lt_of_size_of_branches {t : finite_tree × ℕ} {T : finite_tree} : t ∈ branches T → size t.1 < size T :=
begin
cases T with n ts,
intro h,
assert h' : ∃ i, ts i = t.1, cases h with b hb,
  {exact exists.intro b hb^.left},
cases h' with c hc, rw -hc, apply lt_of_size_branches_aux
end

theorem finite_set_of_branches {n : ℕ} (ts : fin n → finite_tree) : finite (branches_aux ts) :=
let f (a : fin n) : finite_tree × ℕ := (ts a, val a) in
let S : set (finite_tree × ℕ) := {x : finite_tree × ℕ | ∃ a : fin n, f a = x} in
have finS : finite S, from finite_image_of_fin f,
have H1 : S ⊆ branches_aux ts, from
  λ x ⟨a,h⟩, ⟨a,⟨by rw -h,by rw -h⟩⟩,
have H2 : branches_aux ts ⊆ S, from
  λ x ⟨a,h⟩, ⟨a,begin dsimp,rw [h^.left, h^.right], apply prod_eta end⟩,
begin rw -(subset.antisymm H1 H2), exact finS end

theorem finite_branches (t : finite_tree) : finite (branches t) :=
by induction t; apply finite_set_of_branches

#check @minimal_bad_seq

section
parameter H : ∃ f, ¬ is_good f embeds

definition mbs_of_finite_tree := minimal_bad_seq size H

theorem bad_mbs_finite_tree : ¬ is_good mbs_of_finite_tree embeds := badness_of_mbs size H

theorem ne_node_of_elt_of_mbs_finite_tree (n : ℕ) {ts : fin 0 → finite_tree} : mbs_of_finite_tree n ≠ cons ts :=
assume Hneg,
have cons ts  ≼ mbs_of_finite_tree (succ n), by apply node_embeds,
have Hr : mbs_of_finite_tree n ≼ mbs_of_finite_tree (succ n), by simph,
have n < succ n, from lt_succ_self n,
have is_good mbs_of_finite_tree embeds, from exists.intro n (exists.intro (succ n) (and.intro this Hr)),
show _, from bad_mbs_finite_tree this

theorem minimality_of_mbs_finite_tree0 (f : ℕ → finite_tree) (Hf : ¬ is_good f embeds) : size (mbs_of_finite_tree 0) ≤ size (f 0) := minimality_of_mbs_0 size H f Hf

theorem minimality_of_mbs_finite_tree (n : ℕ) (f : ℕ → finite_tree) (H1 : extends_at n mbs_of_finite_tree f ∧ ¬ is_good f embeds) : size (mbs_of_finite_tree (succ n)) ≤ size (f (succ n)) := minimality_of_mbs size H n f H1

definition seq_branches_of_mbs_tree (n : ℕ) : set (finite_tree × ℕ) := branches (mbs_of_finite_tree n)

theorem mem_of_seq_branches {n i : ℕ} (ts : fin n → finite_tree) (k : fin n) (Heq : mbs_of_finite_tree i = cons ts) : (ts k, val k) ∈ seq_branches_of_mbs_tree i :=
have ts k = (ts k, val k).1 ∧ val k = (ts k, val k).2, from and.intro rfl rfl,
have ∃ a, ts a = (ts k, val k).1 ∧ val a = (ts k, val k).2, from exists.intro k this,
have (ts k, val k) ∈ branches (cons ts), from this,
by rw -Heq at this;exact this

definition mbs_tree : Type := {t : finite_tree × ℕ // ∃ i, t ∈ seq_branches_of_mbs_tree i}

definition embeds' (t : mbs_tree) (s : mbs_tree) : Prop := t.val.1 ≼ s.val.1

theorem embeds'_refl (t : mbs_tree) : embeds' t t := embeds_refl t.val.1

theorem embeds'_trans (a b c : mbs_tree) : embeds' a b → embeds' b c → embeds' a c :=
assume H₁, assume H₂, embeds_trans H₁ H₂

section

parameter H' : ∃ f, ¬ is_good f embeds'

definition R : ℕ → mbs_tree := some H'

definition family_index (n : ℕ) : ℕ := some ((R n).2)

definition index_set_of_mbs_tree : set ℕ := image family_index  univ

lemma index_ne_empty : index_set_of_mbs_tree ≠ ∅ := ne_empty_of_image_on_univ family_index

definition least_family_index := least index_set_of_mbs_tree index_ne_empty

lemma exists_least : ∃ i, family_index i = least_family_index :=
have least_family_index ∈ index_set_of_mbs_tree, from least_is_mem index_set_of_mbs_tree index_ne_empty,
let ⟨i,h⟩ := this in
⟨i, h^.right⟩

definition least_index : ℕ := some exists_least

definition Kruskal's_g (n : ℕ) : mbs_tree := R (least_index + n)

definition Kruskal's_h (n : ℕ) : ℕ :=  family_index (least_index + n)

theorem bad_Kruskal's_g : ¬ is_good Kruskal's_g embeds' :=
suppose is_good Kruskal's_g embeds',
let ⟨i,j,hij⟩ := this in
have Hr : embeds' (Kruskal's_g i) (Kruskal's_g j), from hij^.right,
have least_index + i < least_index + j, from add_lt_add_left hij^.left _,
have is_good R embeds', from ⟨least_index + i, ⟨least_index + j,⟨this, Hr⟩⟩⟩,
(some_spec H') this

theorem Kruskal's_Hg : ¬ is_good (fst ∘ (val ∘ Kruskal's_g)) embeds := bad_Kruskal's_g

theorem trans_of_Kruskal's_g {i j : ℕ} (H1 : mbs_of_finite_tree i ≼ (Kruskal's_g j).val.1) :
mbs_of_finite_tree i ≼ mbs_of_finite_tree (Kruskal's_h j) :=
have (Kruskal's_g j).val ∈ branches (mbs_of_finite_tree (Kruskal's_h j)), from some_spec (Kruskal's_g j).2,
have (Kruskal's_g j).val.1 ≼ mbs_of_finite_tree (Kruskal's_h j), from embeds_of_branches this,
embeds_trans H1 this

theorem size_elt_Kruskal's_g_lt_mbs_finite_tree (n : ℕ) : size (Kruskal's_g n).val.1 < size (mbs_of_finite_tree (Kruskal's_h n)) :=
lt_of_size_of_branches (some_spec (Kruskal's_g n).2)

theorem Kruskal's_Hbp : size (Kruskal's_g 0).val.1 < size (mbs_of_finite_tree (Kruskal's_h 0)) := size_elt_Kruskal's_g_lt_mbs_finite_tree 0

lemma family_index_in_index_of_mbs_tree (n : ℕ) : Kruskal's_h n ∈ index_set_of_mbs_tree :=
have Kruskal's_h n = family_index (least_index + n), from rfl,
⟨(least_index + n),⟨trivial,rfl⟩⟩

theorem Kruskal's_Hh (n : ℕ) : Kruskal's_h 0 ≤ Kruskal's_h n :=
-- have Kruskal's_h 0 = family_index (least_index + 0), from rfl,
have Kruskal's_h 0 = family_index least_index, from rfl,--by simph,
have family_index least_index = least_family_index, from some_spec exists_least,
have Kruskal's_h 0 = least_family_index, by simph,
begin rw this, apply minimality, apply family_index_in_index_of_mbs_tree end

theorem Kruskal's_H : ∀ i j, mbs_of_finite_tree i ≼ (Kruskal's_g (j - Kruskal's_h 0)).val.1 → mbs_of_finite_tree i ≼ mbs_of_finite_tree (Kruskal's_h (j - Kruskal's_h 0)) := λ i j, λ H1, trans_of_Kruskal's_g H1

definition Kruskal's_comb_seq (n : ℕ) : finite_tree := @comb_seq_with_mbs _ embeds (fst ∘ (val ∘ Kruskal's_g)) Kruskal's_h size H n

theorem Kruskal's_local_contradiction : false := local_contra_of_comb_seq_with_mbs Kruskal's_h size Kruskal's_Hh H Kruskal's_Hg Kruskal's_H Kruskal's_Hbp

end

#check Kruskal's_local_contradiction

theorem embeds'_is_good : ∀ f, is_good f embeds' :=
by_contradiction
(suppose ¬ ∀ f, is_good f embeds',
 have ∃ f, ¬ is_good f embeds', from classical.exists_not_of_not_forall this,
 Kruskal's_local_contradiction this)

instance wqo_mbs_tree : wqo mbs_tree :=
⟨⟨⟨embeds'⟩,embeds'_refl,embeds'_trans⟩,embeds'_is_good⟩

definition wqo_finite_subsets_of_mbs_tree : wqo (finite_subsets mbs_tree) := wqo_finite_subsets

definition os : finite_subsets mbs_tree → finite_subsets mbs_tree → Prop := wqo_finite_subsets_of_mbs_tree.le

-- type mbs_tree is the collection of all branches at roots appearing in the mbs_of_finite_tree
-- hence, mbs_of_finite_tree can be viewed as a sequence on finite_subsets mbs_tree. We call this sequence a copy (or a mirror) of mbs_of_finite_tree.
-- the following theorem says given any sequence f : ℕ → finite_subsets mbs_tree,  there exists i j such that there exists a f' : mbs_tree → mbs_tree which is injective and nondescending from (f i) to (f j).
theorem good_finite_subsets_of_mbs_tree : ∀ f, is_good f os := wqo_finite_subsets_of_mbs_tree.is_good

-- Intuitively, the above f' is already a witness of the goodness of mbs_of_finite_tree, as it maps each branch of mbs_of_finite_tree i to a branch of mbs_of_finite_tree j. (Also note that there is no node in the mbs_of_finite_tree.)

-- However, according to the definition of embeds, f' has to be of type fin n → fin m for some n,m ∈ ℕ, representing a permutation on the labels of the branches. The following construction recovers the desired function from f'.

-- branches at root of mbs_of_finite_tree form a set of mbs_tree
definition elt_mirror (n : ℕ) : set mbs_tree := {x : mbs_tree | x.1 ∈ seq_branches_of_mbs_tree n}

theorem mirror_refl_left (x : mbs_tree) (n : ℕ) : x ∈ elt_mirror n → x.1 ∈ seq_branches_of_mbs_tree n := λ Hx, Hx

theorem mirror_refl_right (x : mbs_tree) (n : ℕ) : x.1 ∈ seq_branches_of_mbs_tree n → x ∈ elt_mirror n := λ Hx, Hx

instance  finite_seq_branches (n : ℕ) : finite (seq_branches_of_mbs_tree n) := finite_branches (mbs_of_finite_tree n)

theorem finite_elt (n : ℕ) : finite (elt_mirror n) :=
have mapsto : maps_to subtype.val (elt_mirror n) (seq_branches_of_mbs_tree n), from λ x Hx, mirror_refl_left x n Hx,
have inj_on subtype.val (elt_mirror n), from λ x₁ x₂ H₁ H₂, subtype.eq,
finite_of_inj_on mapsto this

-- this gives a sequence of finite_subsets of mbs_tree.
-- mirror_of_seq_branches 0 is the branches at the root of the first element of the minimal bad sequence of finite_tree.

definition mirror (n : ℕ) : finite_subsets mbs_tree := ⟨elt_mirror n, finite_elt n⟩

-- (mirror i) is the collection of branches at the root of (mbs_of_finite_tree i)

theorem good_mirror : ∃ i j, i < j ∧ os (mirror i) (mirror j) := good_finite_subsets_of_mbs_tree mirror

section
-- destruct the statement: os (mirror i) (mirror j)
-- we want to show that there exists some i j such that (mbs_of_finite_tree i ≼ mbs_of_finite_tree j)
-- fortunately, i and j from good_mirror suffice
-- this section tries to get an injection "recover" : fin ni → fin nj such that tsi ti ≼ tsj (recover ti) assuming that (mbs_of_finite_tree i = cons tsi) and (mbs_of_finite_tree j = cons tsj). Note that both are not nodes.
parameters {i j : ℕ}
-- -- since finite_subsets_of_mbs_tree is good, we have an injection f' from some set of branches to some set of branches. This is because each set of branches is a subset of mbs_tree.
parameter f' : mbs_tree → mbs_tree
parameter inj : inj_from_to f' (elt_mirror i) (elt_mirror j)
-- -- of course, it is also nondescending by definition.
parameter nond : ∀ a : mbs_tree, a.val ∈ seq_branches_of_mbs_tree i → a.val.1 ≼ (f' a).val.1 ∧  (f' a).val ∈ seq_branches_of_mbs_tree j
-- suppose (mbs_of_finite_tree i) is of the form (cons tsi)
parameters ni nj : ℕ
parameters (tsi : fin ni → finite_tree) (tsj : fin nj → finite_tree)
-- suppose we know that they are destructed
parameter eqi : mbs_of_finite_tree i = cons tsi
parameter eqj : mbs_of_finite_tree j = cons tsj
-- this reminds us that each branch at the root of (mbs_of_finite_tree i) is in (seq_branches_of_mbs_tree i)
parameter Htsi : ∀ a, (tsi a, val a) ∈ seq_branches_of_mbs_tree i

-- lemma eltini (ti : fin ni) : (tsi ti, val ti) ∈ seq_branches_of_mbs_tree i := Htsi ti

-- every ti corresponds to some seq_branches_of_mbs_tree i
lemma foo (ti : fin ni) : ∃ i, (tsi ti, val ti) ∈ seq_branches_of_mbs_tree i := ⟨i,Htsi ti⟩

-- given a ti, find the corresponding mbs_tree of (tsi ti). The intuition is that this mbs_tree is itself, but of a different type.
definition mbst_form (ti : fin ni) : mbs_tree := ⟨(tsi ti, val ti),(foo ti)⟩

theorem mem_mbst_form (a : fin ni) : mbst_form a ∈ elt_mirror i := Htsi a

theorem eq_of_mbst_form {a₁ a₂ : fin ni} (Heq : mbst_form a₁ = mbst_form a₂) : a₁ = a₂ :=
by apply eq_of_veq;super

-- lemma mem (ti : fin ni) : (f' (mbst_form ti)).val ∈ branches (mbs_of_finite_tree j) :=
-- (nond _ (begin dsimp [mbst_form], apply Htsi end))^.right
include eqj

-- recover :
-- 1. find the mbst_form of ti, say x.
-- 2. By nond, we know that (f' x) is in (seq_branches_of_mbs_tree j).
-- 3. (seq_branches_of_mbs_tree j) is just branches (mbs_of_finite_tree j).
-- 4. The latter is just (set_of_branches tsj).
-- 5. This means that some a : fin nj corresponds to ti. 6. By choice, take such a fin nj.

definition recover (ti : fin ni) : fin nj :=
have (f' (mbst_form ti)).val ∈ seq_branches_of_mbs_tree j, from (nond _ (begin dsimp [mbst_form], apply Htsi end))^.right,
have mem : (f' (mbst_form ti)).val ∈ branches (mbs_of_finite_tree j), from this, -- this line is redundant
have branches (mbs_of_finite_tree j) = branches (cons tsj), by rw eqj, -- by rw eqj at this{2};exact this,
-- have branches (mbs_of_finite_tree j) = branches_aux tsj, from this,
have (f' (mbst_form ti)).val ∈ branches_aux tsj, by rw this at mem;exact mem,
-- have ∃ a : fin nj, tsj a = (f' (mbst_form ti)).val.1 ∧ val a = (f' (mbst_form ti)).val.2, from this,
some this

theorem perm_recover (ti : fin ni) : tsi ti ≼ tsj (recover ti) :=
have (f' (mbst_form ti)).val ∈ seq_branches_of_mbs_tree j, from (nond _ (begin dsimp [mbst_form], apply Htsi end))^.right,
have mem : (f' (mbst_form ti)).val ∈ branches (mbs_of_finite_tree j), from this,
-- have branches (mbs_of_finite_tree j) = branches (mbs_of_finite_tree j), from rfl,
have branches (mbs_of_finite_tree j) = branches (cons tsj), by rw eqj, -- by rw eqj at this{2};exact this,
-- have branches (mbs_of_finite_tree j) = branches_aux tsj, from this,
have (f' (mbst_form ti)).val ∈ branches_aux tsj, by rw this at mem;exact mem,
-- have ∃ a : fin nj, tsj a = (f' (mbst_form ti)).val.1 ∧ val a =  (f' (mbst_form ti)).val.2, from this,
have tsj (recover ti) = (f' (mbst_form ti)).val.1, from let ⟨a,b⟩ := some_spec this in a,
have tsi ti ≼ (f' (mbst_form ti)).val.1, from (nond _ (begin dsimp [mbst_form], apply Htsi end))^.left,
by simph

theorem inj_recover : injective recover :=
λ a₁ a₂ Heq,
have (f' (mbst_form a₁)).val ∈ seq_branches_of_mbs_tree j, from (nond _ (begin dsimp [mbst_form], apply Htsi end))^.right,
have mem : (f' (mbst_form a₁)).val ∈ branches (mbs_of_finite_tree j), from this,
-- have branches (mbs_of_finite_tree j) = branches (mbs_of_finite_tree j), from rfl,
have branches (mbs_of_finite_tree j) = branches (cons tsj), by rw eqj, -- by rw eqj at this{2};exact this,
-- have branches (mbs_of_finite_tree j) = branches_aux tsj, from this,
have (f' (mbst_form a₁)).val ∈ branches_aux tsj, by rw this at mem;exact mem,

have eeq1 : ∃ a : fin nj, tsj a = (f' (mbst_form a₁)).val.1 ∧ val a = (f' (mbst_form a₁)).val.2, from this,
have pr11 : tsj (recover a₁) = (f' (mbst_form a₁)).val.1, from let ⟨a,b⟩ := some_spec eeq1 in a,-- proof and.left (some_spec eeq1) qed,
have pr21 : val (recover a₁) = (f' (mbst_form a₁)).val.2, from let ⟨a,b⟩ := some_spec eeq1 in b, -- proof and.right (some_spec eeq1) qed,
have (f' (mbst_form a₂)).val ∈ seq_branches_of_mbs_tree j, from (nond _ (begin dsimp [mbst_form], apply Htsi end))^.right,-- proof and.right (nond _ (eltini a₂)) qed,
have mem : (f' (mbst_form a₂)).val ∈ branches (mbs_of_finite_tree j), from this,
-- have branches (mbs_of_finite_tree j) = branches (mbs_of_finite_tree j), from rfl,
have branches (mbs_of_finite_tree j) = branches (cons tsj), by rw eqj, -- by+ rw eqj at this{2};exact this,
-- have branches (mbs_of_finite_tree j) = branches_aux tsj, from this,
have (f' (mbst_form a₂)).val ∈ branches_aux tsj, by rw this at mem;exact mem,
have eeq2 : ∃ a : fin nj, tsj a = (f' (mbst_form a₂)).val.1 ∧ val a = (f' (mbst_form a₂)).val.2, from this,
have pr12 : tsj (recover a₂) = (f' (mbst_form a₂)).val.1,  from let ⟨a,b⟩ := some_spec eeq2 in a,-- proof and.left (some_spec eeq2) qed,
have pr22 : val (recover a₂) = (f' (mbst_form a₂)).val.2, from let ⟨a,b⟩ := some_spec eeq2 in b,-- proof and.right (some_spec eeq2) qed,
have eq1 : (f' (mbst_form a₁)).val.1 = (f' (mbst_form a₂)).val.1, by rw [-pr12, -pr11, Heq],
have (f' (mbst_form a₁)).val.2 = (f' (mbst_form a₂)).val.2, by rw [-pr22,-pr21,Heq],
have (f' (mbst_form a₁)).val = (f' (mbst_form a₂)).val, from eq_of_prod eq1 this,
have f'eq : f' (mbst_form a₁) = f' (mbst_form a₂), from subtype.eq this,
have ∀ x₁ x₂ : mbs_tree, x₁ ∈ elt_mirror i → x₂ ∈ elt_mirror i → f' x₁ = f' x₂ → x₁ = x₂, from and.right inj,
have mbst_form a₁ = mbst_form a₂, from this (mbst_form a₁) (mbst_form a₂) (mem_mbst_form a₁) (mem_mbst_form a₂) f'eq,
show _, from eq_of_mbst_form this

end

#check @recover
#check inj_recover

theorem good_mbs_of_finite_tree :  ∃ i j, i < j ∧ mbs_of_finite_tree i ≼ mbs_of_finite_tree j :=
let ⟨i,j,⟨iltj,⟨f',⟨inj,nond⟩⟩⟩⟩ := good_mirror in
let ⟨ni,tsi,htsi⟩ := @finite_tree_destruct (mbs_of_finite_tree i) in
let ⟨nj,tsj,htsj⟩ := @finite_tree_destruct (mbs_of_finite_tree j) in
have Htsi : ∀ a, (tsi a, val a) ∈ seq_branches_of_mbs_tree i, from take a, mem_of_seq_branches tsi a htsi,
let f (a : fin ni) : fin nj := recover f' nond ni _ tsi tsj htsj Htsi a in
have injf : injective f, from inj_recover _ inj _ _ _ _ _ _ _,
have ∀ z : fin ni, tsi z ≼ tsj (f z), from λ z, perm_recover _ _ _ _ _ _ _ _ _,
have cons tsi ≼ cons tsj, from or.inr ⟨f,⟨injf,this⟩⟩,
have mbs_of_finite_tree i ≼ mbs_of_finite_tree j, by simph,
⟨i,j,⟨iltj,this⟩⟩

theorem Kruskal's_contradiction : false := bad_mbs_finite_tree good_mbs_of_finite_tree

end

theorem embeds_is_good : ∀ f, is_good f embeds :=
by_contradiction
(suppose ¬ ∀ f, is_good f embeds,
 have ∃ f, ¬ is_good f embeds, from classical.exists_not_of_not_forall this,
 Kruskal's_contradiction this)

def wqo_finite_tree : wqo finite_tree :=
⟨⟨⟨embeds⟩,embeds_refl,@embeds_trans⟩,embeds_is_good⟩


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

Free groups as a quotient over the reduction relation `a * x * x⁻¹ * b = a * b`.

First we introduce the one step reduction relation
  `free_group.red.step`:  w * x * x⁻¹ * v   ~>   w * v
its reflexive transitive closure:
  `free_group.red.trans`
and proof that its join is an equivalence relation.

Then we introduce `free_group α` as a quotient over `free_group.red.step`.
-/
import logic.relation
import algebra.group algebra.group_power
import data.fintype data.list.basic data.quot
import group_theory.subgroup
open relation

universes u v w

variables {α : Type u}

local attribute [simp] list.append_eq_has_append

namespace free_group
variables {L L₁ L₂ L₃ L₄ : list (α × bool)}

/-- Reduction step: `w * x * x⁻¹ * v ~> w * v` -/
inductive red.step : list (α × bool) → list (α × bool) → Prop
| bnot {L₁ L₂ x b} : red.step (L₁ ++ (x, b) :: (x, bnot b) :: L₂) (L₁ ++ L₂)
attribute [simp] red.step.bnot

/-- Reflexive-transitive closure of red.step -/
def red : list (α × bool) → list (α × bool) → Prop := refl_trans_gen red.step

@[refl] lemma red.refl : red L L := refl_trans_gen.refl
@[trans] lemma red.trans : red L₁ L₂ → red L₂ L₃ → red L₁ L₃ := refl_trans_gen.trans

namespace red

/-- Predicate asserting that word `w₁` can be reduced to `w₂` in one step, i.e. there are words
`w₃ w₄` and letter `x` such that `w₁ = w₃xx⁻¹w₄` and `w₂ = w₃w₄`  -/
theorem step.length : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.length + 2 = L₁.length
| _ _ (@red.step.bnot _ L1 L2 x b) := by rw [list.length_append, list.length_append]; refl

@[simp] lemma step.bnot_rev {x b} : step (L₁ ++ (x, bnot b) :: (x, b) :: L₂) (L₁ ++ L₂) :=
by cases b; from step.bnot

@[simp] lemma step.cons_bnot {x b} : red.step ((x, b) :: (x, bnot b) :: L) L :=
@step.bnot _ [] _ _ _

@[simp] lemma step.cons_bnot_rev {x b} : red.step ((x, bnot b) :: (x, b) :: L) L :=
@red.step.bnot_rev _ [] _ _ _

theorem step.append_left : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₂ L₃ → step (L₁ ++ L₂) (L₁ ++ L₃)
| _ _ _ red.step.bnot := by rw [← list.append_assoc, ← list.append_assoc]; constructor

theorem step.cons {x} (H : red.step L₁ L₂) : red.step (x :: L₁) (x :: L₂) :=
@step.append_left _ [x] _ _ H

theorem step.append_right : ∀ {L₁ L₂ L₃ : list (α × bool)}, step L₁ L₂ → step (L₁ ++ L₃) (L₂ ++ L₃)
| _ _ _ red.step.bnot := by simp

lemma not_step_nil : ¬ step [] L :=
begin
  generalize h' : [] = L',
  assume h,
  cases h with L₁ L₂,
  simp [list.nil_eq_append_iff] at h',
  contradiction
end

lemma step.cons_left_iff {a : α} {b : bool} :
  step ((a, b) :: L₁) L₂ ↔ (∃L, step L₁ L ∧ L₂ = (a, b) :: L) ∨ (L₁ = (a, bnot b)::L₂) :=
begin
  split,
  { generalize hL : ((a, b) :: L₁ : list _) = L,
    assume h,
    rcases h with ⟨_ | ⟨p, s'⟩, e, a', b'⟩,
    { simp at hL, simp [*] },
    { simp at hL,
      rcases hL with ⟨rfl, rfl⟩,
      refine or.inl ⟨s' ++ e, step.bnot, _⟩,
      simp } },
  { assume h,
    rcases h with ⟨L, h, rfl⟩ | rfl,
    { exact step.cons h },
    { exact step.cons_bnot } }
end

lemma not_step_singleton : ∀ {p : α × bool}, ¬ step [p] L
| (a, b) := by simp [step.cons_left_iff, not_step_nil]

lemma step.cons_cons_iff : ∀{p : α × bool}, step (p :: L₁) (p :: L₂) ↔ step L₁ L₂ :=
by simp [step.cons_left_iff, iff_def, or_imp_distrib] {contextual := tt}

lemma step.append_left_iff : ∀L, step (L ++ L₁) (L ++ L₂) ↔ step L₁ L₂
| [] := by simp
| (p :: l) := by simp [step.append_left_iff l, step.cons_cons_iff]

private theorem step.diamond_aux : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)} {x1 b1 x2 b2},
  L₁ ++ (x1, b1) :: (x1, bnot b1) :: L₂ = L₃ ++ (x2, b2) :: (x2, bnot b2) :: L₄ →
  L₁ ++ L₂ = L₃ ++ L₄ ∨ ∃ L₅, red.step (L₁ ++ L₂) L₅ ∧ red.step (L₃ ++ L₄) L₅
| []        _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []        _ [(x3,b3)] _ _ _ _ _ H := by injections; subst_vars; simp
| [(x3,b3)] _ []        _ _ _ _ _ H := by injections; subst_vars; simp
| []                     _ ((x3,b3)::(x4,b4)::tl) _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.bnot, red.step.cons_bnot⟩
| ((x3,b3)::(x4,b4)::tl) _ []                     _ _ _ _ _ H :=
  by injections; subst_vars; simp; right; exact ⟨_, red.step.cons_bnot, red.step.bnot⟩
| ((x3,b3)::tl) _ ((x4,b4)::tl2) _ _ _ _ _ H :=
  let ⟨H1, H2⟩ := list.cons.inj H in
  match step.diamond_aux H2 with
    | or.inl H3 := or.inl $ by simp [H1, H3]
    | or.inr ⟨L₅, H3, H4⟩ := or.inr
      ⟨_, step.cons H3, by simpa [H1] using step.cons H4⟩
  end

theorem step.diamond : ∀ {L₁ L₂ L₃ L₄ : list (α × bool)},
  red.step L₁ L₃ → red.step L₂ L₄ → L₁ = L₂ →
  L₃ = L₄ ∨ ∃ L₅, red.step L₃ L₅ ∧ red.step L₄ L₅
| _ _ _ _ red.step.bnot red.step.bnot H := step.diamond_aux H

lemma step.to_red : step L₁ L₂ → red L₁ L₂ :=
refl_trans_gen.single

/-- Church-Rosser theorem for word reduction: If `w1 w2 w3` are words such that `w1` reduces to `w2`
and `w3` respectively, then there is a word `w4` such that `w2` and `w3` reduce to `w4` respectively. -/
theorem church_rosser : red L₁ L₂ → red L₁ L₃ → join red L₂ L₃ :=
relation.church_rosser (assume a b c hab hac,
match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, hcd.to_red⟩
end)

lemma cons_cons {p} : red L₁ L₂ → red (p :: L₁) (p :: L₂) :=
refl_trans_gen_lift (list.cons p) (assume a b, step.cons)

lemma cons_cons_iff (p) : red (p :: L₁) (p :: L₂) ↔ red L₁ L₂ :=
iff.intro
  begin
    generalize eq₁ : (p :: L₁ : list _) = LL₁,
    generalize eq₂ : (p :: L₂ : list _) = LL₂,
    assume h,
    induction h using relation.refl_trans_gen.head_induction_on
      with L₁ L₂ h₁₂ h ih
      generalizing L₁ L₂,
    { subst_vars, cases eq₂, constructor },
    { subst_vars,
      cases p with a b,
      rw [step.cons_left_iff] at h₁₂,
      rcases h₁₂ with ⟨L, h₁₂, rfl⟩ | rfl,
      { exact (ih rfl rfl).head h₁₂ },
      { exact (cons_cons h).tail step.cons_bnot_rev } }
  end
  cons_cons

lemma append_append_left_iff : ∀L, red (L ++ L₁) (L ++ L₂) ↔ red L₁ L₂
| []       := iff.refl _
| (p :: L) := by simp [append_append_left_iff L, cons_cons_iff]

lemma append_append (h₁ : red L₁ L₃) (h₂ : red L₂ L₄) : red (L₁ ++ L₂) (L₃ ++ L₄) :=
(refl_trans_gen_lift (λL, L ++ L₂) (assume a b, step.append_right) h₁).trans
  ((append_append_left_iff _).2 h₂)

lemma to_append_iff : red L (L₁ ++ L₂) ↔ (∃L₃ L₄, L = L₃ ++ L₄ ∧ red L₃ L₁ ∧ red L₄ L₂) :=
iff.intro
  begin
    generalize eq : L₁ ++ L₂ = L₁₂,
    assume h,
    induction h with L' L₁₂ hLL' h ih generalizing L₁ L₂,
    { exact ⟨_, _, eq.symm, by refl, by refl⟩ },
    { cases h with s e a b,
      rcases list.append_eq_append_iff.1 eq with ⟨s', rfl, rfl⟩ | ⟨e', rfl, rfl⟩,
      { have : L₁ ++ (s' ++ ((a, b) :: (a, bnot b) :: e)) = (L₁ ++ s') ++ ((a, b) :: (a, bnot b) :: e),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁, h₂.tail step.bnot⟩ },
      { have : (s ++ ((a, b) :: (a, bnot b) :: e')) ++ L₂ = s ++ ((a, b) :: (a, bnot b) :: (e' ++ L₂)),
        { simp },
        rcases ih this with ⟨w₁, w₂, rfl, h₁, h₂⟩,
        exact ⟨w₁, w₂, rfl, h₁.tail step.bnot, h₂⟩ }, }
  end
  (assume ⟨L₃, L₄, eq, h₃, h₄⟩, eq.symm ▸ append_append h₃ h₄)

/-- The empty word `[]` only reduces to itself. -/
theorem nil_iff : red [] L ↔ L = [] :=
refl_trans_gen_iff_eq (assume l, red.not_step_nil)

/-- A letter only reduces to itself. -/
theorem singleton_iff {x} : red [x] L₁ ↔ L₁ = [x] :=
refl_trans_gen_iff_eq (assume l, not_step_singleton)

/-- If `x` is a letter and `w` is a word such that `xw` reduces to the empty word, then `w` reduces
to `x⁻¹` -/
theorem cons_nil_iff_singleton {x b} : red ((x, b) :: L) [] ↔ red L [(x, bnot b)] :=
iff.intro
  (assume h,
    have h₁ : red ((x, bnot b) :: (x, b) :: L) [(x, bnot b)], from cons_cons h,
    have h₂ : red ((x, bnot b) :: (x, b) :: L) L, from refl_trans_gen.single step.cons_bnot_rev,
    let ⟨L', h₁, h₂⟩ := church_rosser h₁ h₂ in
    by rw [singleton_iff] at h₁; subst L'; assumption)
  (assume h, (cons_cons h).tail step.cons_bnot)

theorem red_iff_irreducible {x1 b1 x2 b2} (h : (x1, b1) ≠ (x2, b2)) :
  red [(x1, bnot b1), (x2, b2)] L ↔ L = [(x1, bnot b1), (x2, b2)] :=
begin
  apply refl_trans_gen_iff_eq,
  generalize eq : [(x1, bnot b1), (x2, b2)] = L',
  assume L h',
  cases h',
  simp [list.cons_eq_append_iff, list.nil_eq_append_iff] at eq,
  rcases eq with ⟨rfl, ⟨rfl, rfl⟩, ⟨rfl, rfl⟩, rfl⟩, subst_vars,
  simp at h,
  contradiction
end

/-- If `x` and `y` are distinct letters and `w₁ w₂` are words such that `xw₁` reduces to `yw₂`, then
`w₁` reduces to `x⁻¹yw₂`. -/
theorem inv_of_red_of_ne {x1 b1 x2 b2}
  (H1 : (x1, b1) ≠ (x2, b2))
  (H2 : red ((x1, b1) :: L₁) ((x2, b2) :: L₂)) :
  red L₁ ((x1, bnot b1) :: (x2, b2) :: L₂) :=
begin
  have : red ((x1, b1) :: L₁) ([(x2, b2)] ++ L₂), from H2,
  rcases to_append_iff.1 this with ⟨_ | ⟨p, L₃⟩, L₄, eq, h₁, h₂⟩,
  { simp [nil_iff] at h₁, contradiction },
  { cases eq,
    show red (L₃ ++ L₄) ([(x1, bnot b1), (x2, b2)] ++ L₂),
    apply append_append _ h₂,
    have h₁ : red ((x1, bnot b1) :: (x1, b1) :: L₃) [(x1, bnot b1), (x2, b2)],
    { exact cons_cons h₁ },
    have h₂ : red ((x1, bnot b1) :: (x1, b1) :: L₃) L₃,
    { exact step.cons_bnot_rev.to_red },
    rcases church_rosser h₁ h₂ with ⟨L', h₁, h₂⟩,
    rw [red_iff_irreducible H1] at h₁,
    rwa [h₁] at h₂ }
end

theorem step.sublist (H : red.step L₁ L₂) : L₂ <+ L₁ :=
by cases H; simp; constructor; constructor; refl

/-- If `w₁ w₂` are words such that `w₁` reduces to `w₂`, then `w₂` is a sublist of `w₁`. -/
theorem sublist : red L₁ L₂ → L₂ <+ L₁ :=
refl_trans_gen_of_transitive_reflexive
  (λl, list.sublist.refl l) (λa b c hab hbc, list.sublist.trans hbc hab) (λa b, red.step.sublist)

theorem sizeof_of_step : ∀ {L₁ L₂ : list (α × bool)}, step L₁ L₂ → L₂.sizeof < L₁.sizeof
| _ _ (@step.bnot _ L1 L2 x b) :=
  begin
    induction L1 with hd tl ih,
    case list.nil
    { dsimp [list.sizeof],
      have H : 1 + sizeof (x, b) + (1 + sizeof (x, bnot b) + list.sizeof L2)
        = (list.sizeof L2 + 1) + (sizeof (x, b) + sizeof (x, bnot b) + 1),
      { ac_refl },
      rw H,
      exact nat.le_add_right _ _ },
    case list.cons
    { dsimp [list.sizeof],
      exact nat.add_lt_add_left ih _ }
  end

theorem length (h : red L₁ L₂) : ∃ n, L₁.length = L₂.length + 2 * n :=
begin
  induction h with L₂ L₃ h₁₂ h₂₃ ih,
  { exact ⟨0, rfl⟩ },
  { rcases ih with ⟨n, eq⟩,
    existsi (1 + n),
    simp [mul_add, eq, (step.length h₂₃).symm] }
end

theorem antisymm (h₁₂ : red L₁ L₂) : red L₂ L₁ → L₁ = L₂ :=
match L₁, h₁₂.cases_head with
| _,  or.inl rfl            := assume h, rfl
| L₁, or.inr ⟨L₃, h₁₃, h₃₂⟩ := assume h₂₁,
  let ⟨n, eq⟩ := length (h₃₂.trans h₂₁) in
  have list.length L₃ + 0 = list.length L₃ + (2 * n + 2),
    by simpa [(step.length h₁₃).symm, add_comm, add_assoc] using eq,
  (nat.no_confusion $ nat.add_left_cancel this)
end

end red

theorem equivalence_join_red : equivalence (join (@red α)) :=
equivalence_join_refl_trans_gen $ assume a b c hab hac,
(match b, c, red.step.diamond hab hac rfl with
| b, _, or.inl rfl           := ⟨b, by refl, by refl⟩
| b, c, or.inr ⟨d, hbd, hcd⟩ := ⟨d, refl_gen.single hbd, refl_trans_gen.single hcd⟩
end)

theorem join_red_of_step (h : red.step L₁ L₂) : join red L₁ L₂ :=
join_of_single reflexive_refl_trans_gen h.to_red

theorem eqv_gen_step_iff_join_red : eqv_gen red.step L₁ L₂ ↔ join red L₁ L₂ :=
iff.intro
  (assume h,
    have eqv_gen (join red) L₁ L₂ := eqv_gen_mono (assume a b, join_red_of_step) h,
    (eqv_gen_iff_of_equivalence $ equivalence_join_red).1 this)
  (join_of_equivalence (eqv_gen.is_equivalence _) $ assume a b,
    refl_trans_gen_of_equivalence (eqv_gen.is_equivalence _) eqv_gen.rel)

end free_group

/-- The free group over a type, i.e. the words formed by the elements of the type and their formal
inverses, quotient by one step reduction. -/
def free_group (α : Type u) : Type u :=
quot $ @free_group.red.step α

namespace free_group

variables {α} {L L₁ L₂ L₃ L₄ : list (α × bool)}

def mk (L) : free_group α := quot.mk red.step L

@[simp] lemma quot_mk_eq_mk : quot.mk red.step L = mk L := rfl

@[simp] lemma quot_lift_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift f H (mk L) = f L := rfl

@[simp] lemma quot_lift_on_mk (β : Type v) (f : list (α × bool) → β)
  (H : ∀ L₁ L₂, red.step L₁ L₂ → f L₁ = f L₂) :
quot.lift_on (mk L) f H = f L := rfl

instance : has_one (free_group α) := ⟨mk []⟩
lemma one_eq_mk : (1 : free_group α) = mk [] := rfl

instance : has_mul (free_group α) :=
⟨λ x y, quot.lift_on x
    (λ L₁, quot.lift_on y (λ L₂, mk $ L₁ ++ L₂) (λ L₂ L₃ H, quot.sound $ red.step.append_left H))
    (λ L₁ L₂ H, quot.induction_on y $ λ L₃, quot.sound $ red.step.append_right H)⟩
@[simp] lemma mul_mk : mk L₁ * mk L₂ = mk (L₁ ++ L₂) := rfl

instance : has_inv (free_group α) :=
⟨λx, quot.lift_on x (λ L, mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse)
  (assume a b h, quot.sound $ by cases h; simp)⟩
@[simp] lemma inv_mk : (mk L)⁻¹ = mk (L.map $ λ x : α × bool, (x.1, bnot x.2)).reverse := rfl

instance : group (free_group α) :=
{ mul := (*),
  one := 1,
  inv := has_inv.inv,
  mul_assoc := by rintros ⟨L₁⟩ ⟨L₂⟩ ⟨L₃⟩; simp,
  one_mul := by rintros ⟨L⟩; refl,
  mul_one := by rintros ⟨L⟩; simp [one_eq_mk],
  mul_left_inv := by rintros ⟨L⟩; exact (list.rec_on L rfl $
    λ ⟨x, b⟩ tl ih, eq.trans (quot.sound $ by simp [one_eq_mk]) ih) }

/-- `of x` is the canonical injection from the type to the free group over that type by sending each
element to the equivalence class of the letter that is the element. -/
def of (x : α) : free_group α :=
mk [(x, tt)]

theorem red.exact : mk L₁ = mk L₂ ↔ join red L₁ L₂ :=
calc (mk L₁ = mk L₂) ↔ eqv_gen red.step L₁ L₂ : iff.intro (quot.exact _) quot.eqv_gen_sound
  ... ↔ join red L₁ L₂ : eqv_gen_step_iff_join_red

/-- The canonical injection from the type to the free group is an injection. -/
theorem of.inj {x y : α} (H : of x = of y) : x = y :=
let ⟨L₁, hx, hy⟩ := red.exact.1 H in
by simp [red.singleton_iff] at hx hy; cc

section to_group

variables {β : Type v} [group β] (f : α → β) {x y : free_group α}

def to_group.aux : list (α × bool) → β :=
λ L, list.prod $ L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹

theorem red.step.to_group {f : α → β} (H : red.step L₁ L₂) :
  to_group.aux f L₁ = to_group.aux f L₂ :=
by cases H with _ _ _ b; cases b; simp [to_group.aux]

/-- If `β` is a group, then any function from `α` to `β`
extends uniquely to a group homomorphism from
the free group over `α` to `β` -/
def to_group : free_group α → β :=
quot.lift (to_group.aux f) $ λ L₁ L₂ H, red.step.to_group H

variable {f}

@[simp] lemma to_group.mk : to_group f (mk L) =
  list.prod (L.map $ λ x, cond x.2 (f x.1) (f x.1)⁻¹) :=
rfl

@[simp] lemma to_group.of {x} : to_group f (of x) = f x :=
one_mul _

instance to_group.is_group_hom : is_group_hom (to_group f) :=
⟨by rintros ⟨L₁⟩ ⟨L₂⟩; simp⟩

@[simp] lemma to_group.mul : to_group f (x * y) = to_group f x * to_group f y :=
is_group_hom.mul _ _ _

@[simp] lemma to_group.one : to_group f 1 = 1 :=
is_group_hom.one _

@[simp] lemma to_group.inv : to_group f x⁻¹ = (to_group f x)⁻¹ :=
is_group_hom.inv _ _

theorem to_group.unique (g : free_group α → β) [is_group_hom g]
  (hg : ∀ x, g (of x) = f x) : ∀{x}, g x = to_group f x :=
by rintros ⟨L⟩; exact list.rec_on L (is_group_hom.one g)
(λ ⟨x, b⟩ t (ih : g (mk t) = _), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = to_group f (mk ((x, ff) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux])
  (show g (of x * mk t) = to_group f (mk ((x, tt) :: t)),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih, to_group, to_group.aux]))

theorem to_group.of_eq (x : free_group α) : to_group of x = x :=
eq.symm $ to_group.unique id (λ x, rfl)

theorem to_group.range_subset {s : set β} [is_subgroup s] (H : set.range f ⊆ s) :
  set.range (to_group f) ⊆ s :=
by rintros _ ⟨⟨L⟩, rfl⟩; exact list.rec_on L (is_submonoid.one_mem s)
(λ ⟨x, b⟩ tl ih, bool.rec_on b
    (by simp at ih ⊢; from is_submonoid.mul_mem
      (is_subgroup.inv_mem $ H ⟨x, rfl⟩) ih)
    (by simp at ih ⊢; from is_submonoid.mul_mem (H ⟨x, rfl⟩) ih))

theorem to_group.range_eq_closure :
  set.range (to_group f) = group.closure (set.range f) :=
set.subset.antisymm
  (to_group.range_subset group.subset_closure)
  (group.closure_subset $ λ y ⟨x, hx⟩, ⟨of x, by simpa⟩)

end to_group

section map

variables {β : Type v} (f : α → β) {x y : free_group α}

def map.aux (L : list (α × bool)) : list (β × bool) :=
L.map $ λ x, (f x.1, x.2)

/-- Any function from `α` to `β` extends uniquely
to a group homomorphism from the free group
ver `α` to the free group over `β`. -/
def map (x : free_group α) : free_group β :=
x.lift_on (λ L, mk $ map.aux f L) $
λ L₁ L₂ H, quot.sound $ by cases H; simp [map.aux]

instance map.is_group_hom : is_group_hom (map f) :=
⟨by rintros ⟨L₁⟩ ⟨L₂⟩; simp [map, map.aux]⟩

variable {f}

@[simp] lemma map.mk : map f (mk L) = mk (L.map (λ x, (f x.1, x.2))) :=
rfl

@[simp] lemma map.id : map id x = x :=
have H1 : (λ (x : α × bool), x) = id := rfl,
by rcases x with ⟨L⟩; simp [H1]

@[simp] lemma map.id' : map (λ z, z) x = x := map.id

theorem map.comp {γ : Type w} {f : α → β} {g : β → γ} {x} :
  map g (map f x) = map (g ∘ f) x :=
by rcases x with ⟨L⟩; simp

@[simp] lemma map.of {x} : map f (of x) = of (f x) := rfl

@[simp] lemma map.mul : map f (x * y) = map f x * map f y :=
is_group_hom.mul _ x y

@[simp] lemma map.one : map f 1 = 1 :=
is_group_hom.one _

@[simp] lemma map.inv : map f x⁻¹ = (map f x)⁻¹ :=
is_group_hom.inv _ x

theorem map.unique (g : free_group α → free_group β) [is_group_hom g]
  (hg : ∀ x, g (of x) = of (f x)) : ∀{x}, g x = map f x :=
by rintros ⟨L⟩; exact list.rec_on L (is_group_hom.one g)
(λ ⟨x, b⟩ t (ih : g (mk t) = map f (mk t)), bool.rec_on b
  (show g ((of x)⁻¹ * mk t) = map f ((of x)⁻¹ * mk t),
     by simp [is_group_hom.mul g, is_group_hom.inv g, hg, ih])
  (show g (of x * mk t) = map f (of x * mk t),
     by simp [is_group_hom.mul g, hg, ih]))

/-- Equivalent types give rise to equivalent free groups. -/
def free_group_congr {α β} (e : α ≃ β) : free_group α ≃ free_group β :=
⟨map e, map e.symm,
 λ x, by simp [function.comp, map.comp],
 λ x, by simp [function.comp, map.comp]⟩

theorem map_eq_to_group : map f x = to_group (of ∘ f) x :=
eq.symm $ map.unique _ $ λ x, by simp

end map

section prod

variables [group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the multiplicative
version of `sum`. -/
def prod : α :=
to_group id x

variables {x y}

@[simp] lemma prod_mk :
  prod (mk L) = list.prod (L.map $ λ x, cond x.2 x.1 x.1⁻¹) :=
rfl

@[simp] lemma prod.of {x : α} : prod (of x) = x :=
to_group.of

instance prod.is_group_hom : is_group_hom (@prod α _) :=
to_group.is_group_hom

@[simp] lemma prod.mul : prod (x * y) = prod x * prod y :=
to_group.mul

@[simp] lemma prod.one : prod (1:free_group α) = 1 :=
to_group.one

@[simp] lemma prod.inv : prod x⁻¹ = (prod x)⁻¹ :=
to_group.inv

lemma prod.unique (g : free_group α → α) [is_group_hom g]
  (hg : ∀ x, g (of x) = x) {x} :
  g x = prod x :=
to_group.unique g hg

end prod

theorem to_group_eq_prod_map {β : Type v} [group β] {f : α → β} {x} :
  to_group f x = prod (map f x) :=
eq.symm $ to_group.unique (prod ∘ map f) $ λ _, by simp

section sum

variables [add_group α] (x y : free_group α)

/-- If `α` is a group, then any function from `α` to `α`
extends uniquely to a homomorphism from the
free group over `α` to `α`. This is the additive
version of `prod`. -/
def sum : α :=
@prod (multiplicative _) _ x

variables {x y}

@[simp] lemma sum_mk :
  sum (mk L) = list.sum (L.map $ λ x, cond x.2 x.1 (-x.1)) :=
rfl

@[simp] lemma sum.of {x : α} : sum (of x) = x :=
prod.of

instance sum.is_group_hom : is_group_hom (@sum α _) :=
prod.is_group_hom

@[simp] lemma sum.sum : sum (x * y) = sum x + sum y :=
prod.mul

@[simp] lemma sum.one : sum (1:free_group α) = 0 :=
prod.one

@[simp] lemma sum.inv : sum x⁻¹ = -sum x :=
prod.inv

end sum

def free_group_empty_equiv_unit : free_group empty ≃ unit :=
{ to_fun    := λ _, (),
  inv_fun   := λ _, 1,
  left_inv  := by rintros ⟨_ | ⟨⟨⟨⟩, _⟩, _⟩⟩; refl,
  right_inv := λ ⟨⟩, rfl }

def free_group_unit_equiv_int : free_group unit ≃ int :=
{ to_fun    := λ x, sum $ map (λ _, 1) x,
  inv_fun   := λ x, of () ^ x,
  left_inv  := by rintros ⟨L⟩; exact list.rec_on L rfl
    (λ ⟨⟨⟩, b⟩ tl ih, by cases b; simp [gpow_add] at ih ⊢; rw ih; refl),
  right_inv := λ x, int.induction_on x (by simp)
    (λ i ih, by simp at ih; simp [gpow_add, ih])
    (λ i ih, by simp at ih; simp [gpow_add, ih]) }

section category

variables {β : Type u}

instance : monad free_group.{u} :=
{ pure := λ α, of,
  map := λ α β, map,
  bind := λ α β x f, to_group f x }

@[elab_as_eliminator]
protected theorem induction_on
  {C : free_group α → Prop}
  (z : free_group α)
  (C1 : C 1)
  (Cp : ∀ x, C $ pure x)
  (Ci : ∀ x, C (pure x) → C (pure x)⁻¹)
  (Cm : ∀ x y, C x → C y → C (x * y)) : C z :=
quot.induction_on z $ λ L, list.rec_on L C1 $ λ ⟨x, b⟩ tl ih,
bool.rec_on b (Cm _ _ (Ci _ $ Cp x) ih) (Cm _ _ (Cp x) ih)

@[simp] lemma map_pure (f : α → β) (x : α) : f <$> (pure x : free_group α) = pure (f x) :=
map.of

@[simp] lemma map_one (f : α → β) : f <$> (1 : free_group α) = 1 :=
map.one

@[simp] lemma map_mul (f : α → β) (x y : free_group α) : f <$> (x * y) = f <$> x * f <$> y :=
map.mul

@[simp] lemma map_inv (f : α → β) (x : free_group α) : f <$> (x⁻¹) = (f <$> x)⁻¹ :=
map.inv

@[simp] lemma pure_bind (f : α → free_group β) (x) : pure x >>= f = f x :=
to_group.of

@[simp] lemma one_bind (f : α → free_group β) : 1 >>= f = 1 :=
@@to_group.one _ f

@[simp] lemma mul_bind (f : α → free_group β) (x y : free_group α) : x * y >>= f = (x >>= f) * (y >>= f) :=
to_group.mul

@[simp] lemma inv_bind (f : α → free_group β) (x : free_group α) : x⁻¹ >>= f = (x >>= f)⁻¹ :=
to_group.inv

instance : is_lawful_monad free_group.{u} :=
{ id_map := λ α x, free_group.induction_on x (map_one id) (λ x, map_pure id x)
    (λ x ih, by rw [map_inv, ih]) (λ x y ihx ihy, by rw [map_mul, ihx, ihy]),
  pure_bind := λ α β x f, pure_bind f x,
  bind_assoc := λ α β γ x f g, free_group.induction_on x
    (by iterate 3 { rw one_bind }) (λ x, by iterate 2 { rw pure_bind })
    (λ x ih, by iterate 3 { rw inv_bind }; rw ih)
    (λ x y ihx ihy, by iterate 3 { rw mul_bind }; rw [ihx, ihy]),
  bind_pure_comp_eq_map := λ α β f x, free_group.induction_on x
    (by rw [one_bind, map_one]) (λ x, by rw [pure_bind, map_pure])
    (λ x ih, by rw [inv_bind, map_inv, ih]) (λ x y ihx ihy, by rw [mul_bind, map_mul, ihx, ihy]) }

end category

section reduce

variable [decidable_eq α]

/-- The maximal reduction of a word. It is computable
iff `α` has decidable equality. -/
def reduce (L : list (α × bool)) : list (α × bool) :=
list.rec_on L [] $ λ hd1 tl1 ih,
list.cases_on ih [hd1] $ λ hd2 tl2,
if hd1.1 = hd2.1 ∧ hd1.2 = bnot hd2.2 then tl2
else hd1 :: hd2 :: tl2

@[simp] lemma reduce.cons (x) : reduce (x :: L) =
  list.cases_on (reduce L) [x] (λ hd tl,
  if x.1 = hd.1 ∧ x.2 = bnot hd.2 then tl
  else x :: hd :: tl) := rfl

/-- The first theorem that characterises the function
`reduce`: a word reduces to its maximal reduction. -/
theorem reduce.red : red L (reduce L) :=
begin
  induction L with hd1 tl1 ih,
  case list.nil
  { constructor },
  case list.cons
  { dsimp,
    revert ih,
    generalize htl : reduce tl1 = TL,
    intro ih,
    cases TL with hd2 tl2,
    case list.nil
    { exact red.cons_cons ih },
    case list.cons
    { dsimp,
      by_cases h : hd1.fst = hd2.fst ∧ hd1.snd = bnot (hd2.snd),
      { rw [if_pos h],
        transitivity,
        { exact red.cons_cons ih },
        { cases hd1, cases hd2, cases h,
          dsimp at *, subst_vars,
          exact red.step.cons_bnot_rev.to_red } },
      { rw [if_neg h],
        exact red.cons_cons ih } } }
end

theorem reduce.not {p : Prop} : ∀ {L₁ L₂ L₃ : list (α × bool)} {x b}, reduce L₁ = L₂ ++ (x, b) :: (x, bnot b) :: L₃ → p
| [] L2 L3 _ _ := λ h, by cases L2; injections
| ((x,b)::L1) L2 L3 x' b' := begin
  dsimp,
  cases r : reduce L1,
  { dsimp, intro h,
    have := congr_arg list.length h,
    simp [-add_comm] at this,
    exact absurd this dec_trivial },
  cases hd with y c,
  by_cases x = y ∧ b = bnot c; simp [h]; intro H,
  { rw H at r,
    exact @reduce.not L1 ((y,c)::L2) L3 x' b' r },
  rcases L2 with _|⟨a, L2⟩,
  { injections, subst_vars,
    simp at h, cc },
  { refine @reduce.not L1 L2 L3 x' b' _,
    injection H with _ H,
    rw [r, H], refl }
end

/-- The second theorem that characterises the
function `reduce`: the maximal reduction of a word
only reduces to itself. -/
theorem reduce.min (H : red (reduce L₁) L₂) : reduce L₁ = L₂ :=
begin
  induction H with L1 L' L2 H1 H2 ih,
  { refl },
  { cases H1 with L4 L5 x b,
    exact reduce.not H2 }
end

/-- `reduce` is idempotent, i.e. the maximal reduction
of the maximal reduction of a word is the maximal
reduction of the word. -/
theorem reduce.idem : reduce (reduce L) = reduce L :=
eq.symm $ reduce.min reduce.red

theorem reduce.step.eq (H : red.step L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (reduce.red.head H) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If a word reduces to another word, then they have
a common maximal reduction. -/
theorem reduce.eq_of_red (H : red L₁ L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, HR13, HR23⟩ := red.church_rosser reduce.red (red.trans H reduce.red) in
(reduce.min HR13).trans (reduce.min HR23).symm

/-- If two words correspond to the same element in
the free group, then they have a common maximal
reduction. This is the proof that the function that
sends an element of the free group to its maximal
reduction is well-defined. -/
theorem reduce.sound (H : mk L₁ = mk L₂) : reduce L₁ = reduce L₂ :=
let ⟨L₃, H13, H23⟩ := red.exact.1 H in
(reduce.eq_of_red H13).trans (reduce.eq_of_red H23).symm

/-- If two words have a common maximal reduction,
then they correspond to the same element in the free group. -/
theorem reduce.exact (H : reduce L₁ = reduce L₂) : mk L₁ = mk L₂ :=
red.exact.2 ⟨reduce L₂, H ▸ reduce.red, reduce.red⟩

/-- A word and its maximal reduction correspond to
the same element of the free group. -/
theorem reduce.self : mk (reduce L) = mk L :=
reduce.exact reduce.idem

/-- If words `w₁ w₂` are such that `w₁` reduces to `w₂`,
then `w₂` reduces to the maximal reduction of `w₁`. -/
theorem reduce.rev (H : red L₁ L₂) : red L₂ (reduce L₁) :=
(reduce.eq_of_red H).symm ▸ reduce.red

/-- The function that sends an element of the free
group to its maximal reduction. -/
def to_word : free_group α → list (α × bool) :=
quot.lift reduce $ λ L₁ L₂ H, reduce.step.eq H

def to_word.mk : ∀{x : free_group α}, mk (to_word x) = x :=
by rintros ⟨L⟩; exact reduce.self

def to_word.inj : ∀(x y : free_group α), to_word x = to_word y → x = y :=
by rintros ⟨L₁⟩ ⟨L₂⟩; exact reduce.exact

/-- Constructive Church-Rosser theorem (compare `church_rosser`). -/
def reduce.church_rosser (H12 : red L₁ L₂) (H13 : red L₁ L₃) :
  { L₄ // red L₂ L₄ ∧ red L₃ L₄ } :=
⟨reduce L₁, reduce.rev H12, reduce.rev H13⟩

instance : decidable_eq (free_group α) :=
function.injective.decidable_eq to_word.inj

instance red.decidable_rel : decidable_rel (@red α)
| [] []          := is_true red.refl
| [] (hd2::tl2)  := is_false $ λ H, list.no_confusion (red.nil_iff.1 H)
| ((x,b)::tl) [] := match red.decidable_rel tl [(x, bnot b)] with
  | is_true H  := is_true $ red.trans (red.cons_cons H) $
    (@red.step.bnot _ [] [] _ _).to_red
  | is_false H := is_false $ λ H2, H $ red.cons_nil_iff_singleton.1 H2
  end
| ((x1,b1)::tl1) ((x2,b2)::tl2) := if h : (x1, b1) = (x2, b2)
  then match red.decidable_rel tl1 tl2 with
    | is_true H  := is_true $ h ▸ red.cons_cons H
    | is_false H := is_false $ λ H2, H $ h ▸ (red.cons_cons_iff _).1 $ H2
    end
  else match red.decidable_rel tl1 ((x1,bnot b1)::(x2,b2)::tl2) with
    | is_true H  := is_true $ (red.cons_cons H).tail red.step.cons_bnot
    | is_false H := is_false $ λ H2, H $ red.inv_of_red_of_ne h H2
    end

/-- A list containing every word that `w₁` reduces to. -/
def red.enum (L₁ : list (α × bool)) : list (list (α × bool)) :=
list.filter (λ L₂, red L₁ L₂) (list.sublists L₁)

theorem red.enum.sound (H : L₂ ∈ red.enum L₁) : red L₁ L₂ :=
list.of_mem_filter H

theorem red.enum.complete (H : red L₁ L₂) : L₂ ∈ red.enum L₁ :=
list.mem_filter_of_mem (list.mem_sublists.2 $ red.sublist H) H

instance : fintype { L₂ // red L₁ L₂ } :=
fintype.subtype (list.to_finset $ red.enum L₁) $
λ L₂, ⟨λ H, red.enum.sound $ list.mem_to_finset.1 H,
  λ H, list.mem_to_finset.2 $ red.enum.complete H⟩

end reduce

end free_group


import GMLInit.Meta.Basic
import GMLInit.Meta.Decidable
import GMLInit.Meta.Relation

namespace Nat

@[eliminator] protected def recAux.{u} {motive : Nat → Sort u} (zero : motive 0) (succ : (n : Nat) → motive n → motive (n+1)) : (t : Nat) → motive t
| 0 => zero
| n+1 => succ n (Nat.recAux zero succ n)

protected def recAuxOn.{u} {motive : Nat → Sort u} (t : Nat) (zero : motive 0) (succ : (n : Nat) → motive n → motive (n+1)) : motive t :=
  Nat.recAux zero succ t

protected def casesAuxOn.{u} {motive : Nat → Sort u} (t : Nat) (zero : motive 0) (succ : (n : Nat) → motive (n+1)) : motive t :=
  Nat.recAux zero (λ n _ => succ n) t

protected def recDiagAux.{u} {motive : Nat → Nat → Sort u}
  (left : (x : Nat) → motive x 0)
  (right : (y : Nat) → motive 0 y)
  (diag : (x y : Nat) → motive x y → motive (x + 1) (y + 1)) :
  (x y : Nat) → motive x y
| x, 0 => left x
| 0, y => right y
| x + 1, y + 1 => diag x y (Nat.recDiagAux left right diag x y)

protected def recDiagAuxOn.{u} {motive : Nat → Nat → Sort u} (x y : Nat)
  (left : (x : Nat) → motive x 0)
  (right : (y : Nat) → motive 0 y)
  (diag : (x y : Nat) → motive x y → motive (x + 1) (y + 1)) :
  motive x y :=
  Nat.recDiagAux left right diag x y

protected def casesDiagAuxOn.{u} {motive : Nat → Nat → Sort u} (x y : Nat)
  (left : (x : Nat) → motive x 0)
  (right : (y : Nat) → motive 0 y)
  (diag : (x y : Nat) → motive (x + 1) (y + 1)) :
  motive x y :=
  Nat.recDiagAuxOn x y left right (λ x y _ => diag x y)

protected def recDiag.{u} {motive : Nat → Nat → Sort u}
  (zero_zero : motive 0 0)
  (succ_zero : (x : Nat) → motive x 0 → motive (x + 1) 0)
  (zero_succ : (y : Nat) → motive 0 y → motive 0 (y + 1))
  (succ_succ : (x y : Nat) → motive x y → motive (x + 1) (y + 1)) :
  (x y : Nat) → motive x y :=
  Nat.recDiagAux left right succ_succ where
  left : (x : Nat) → motive x 0
  | 0 => zero_zero
  | x+1 => succ_zero x (left x)
  right : (y : Nat) → motive 0 y
  | 0 => zero_zero
  | y+1 => zero_succ y (right y)

protected def recDiagOn.{u} {motive : Nat → Nat → Sort u} (x y : Nat)
  (zero_zero : motive 0 0)
  (succ_zero : (x : Nat) → motive x 0 → motive (x + 1) 0)
  (zero_succ : (y : Nat) → motive 0 y → motive 0 (y + 1))
  (succ_succ : (x y : Nat) → motive x y → motive (x + 1) (y + 1)) :
  motive x y :=
  Nat.recDiag zero_zero succ_zero zero_succ succ_succ x y

protected def casesDiagOn.{u} {motive : Nat → Nat → Sort u} (x y : Nat)
  (zero_zero : motive 0 0)
  (succ_zero : (x : Nat) → motive (x + 1) 0)
  (zero_succ : (y : Nat) → motive 0 (y + 1))
  (succ_succ : (x y : Nat) → motive (x + 1) (y + 1)) :
  motive x y :=
  Nat.recDiagOn x y zero_zero (λ x _ => succ_zero x) (λ y _ => zero_succ y) (λ x y _ => succ_succ x y)

section clean

attribute [clean] Nat.zero_eq Nat.add_eq Nat.sub_eq Nat.mul_eq Nat.div_eq Nat.mod_eq Nat.pow_eq Nat.add_zero Nat.mul_zero Nat.pow_zero

@[simp,clean] protected lemma succ_eq (x : Nat) : Nat.succ x = x + 1 := rfl

@[simp,clean] protected lemma pred_eq (x : Nat) : Nat.pred x = x - 1 := rfl

end clean

end Nat


import pq_like_equalizer_util

universe u

section pq_like_equalizer

-- Idea: Eq(eta, L(eta)) is normal. Useful for proving injectivity?

variables {Q : Type u} [power_quandle Q]

lemma eta_equalizer_iso_forward_of_L_of (x : pq_group (eta_equalizer Q)) : of (eta_equalizer_iso_forward x) = (L_of_morph of of_is_pq_morphism) (eta_equalizer_iso_forward x) :=
begin
  revert x,
  refine pq_group_word_induction _ _,
  {
    simp only [monoid_hom.map_one],
    rw of_one,
  },
  {
    intros x y hx,
    simp only [monoid_hom.map_mul],
    rw ←hx,
    rw eta_equalizer_iso_forward_of,
    cases y with y hy,
    simp only,
    unfold eta_equalizer at hy,
    rw set.mem_def at hy,
    sorry,
  },
end

lemma inclusion_counit_of (x : pq_group (eta_equalizer Q)) : pq_group_eta_equalizer_inclusion x = of (counit (pq_group_eta_equalizer_inclusion x)) :=
begin
  rw inclusion_eq_L_of_of_forward,
  rw counit_L_of,
  rw eta_equalizer_iso_forward_of_L_of,
end

lemma pq_group_eta_equalizer_inclusion_injective : function.injective (pq_group_eta_equalizer_inclusion : pq_group (eta_equalizer Q) → pq_group (pq_group Q)) :=
begin
  --intros x y hxy,
  refine pq_group_eta_equalizer_inclusion.injective_iff.mpr _,
  intros x hx,
  --rw inclusion_eq_L_of_of_forward at hx,

  revert x,
  refine pq_group_list _,
  {
    intros x hxy,
    have hxy_rw : (L_of_morph of of_is_pq_morphism) (list.prod (list.map (λ z : (eta_equalizer Q), ↑z) x)) = pq_group_eta_equalizer_inclusion (list.map of x).prod,
    {
      clear hxy,
      induction x,
      {
        simp only [list.prod_nil, list.map, monoid_hom.map_one],
      },
      {
        simp only [monoid_hom.map_mul, list.prod_cons, list.map],
        simp only at x_ih,
        rw x_ih,
        congr,
        clear x_ih x_tl,
        cases x_hd with x hx,
        simp only [subtype.coe_mk],
        have hx1 := eta_equalizer_mem_def _ hx,
        rw ←hx1,
        refl,
      },
    },
    rw ←hxy_rw at hxy,
    clear hxy_rw,
    sorry,
    /-
    have hxy1 : (list.map (λ z : (eta_equalizer Q), (of (↑z) : pq_group (pq_group Q))) x).prod = pq_group_eta_equalizer_inclusion (list.map of x).prod,
    {
      clear hxy,
      induction x with a b hb,
      {
        simp only [list.prod_nil, list.map, monoid_hom.map_one],
      },
      {
        simp only [monoid_hom.map_mul, list.prod_cons, list.map],
        rw hb,
        cases a with a ha,
        refl,
      },
    },
    rw ←hxy1 at hxy,
    clear hxy1,
    induction x with y x hx,
    {
      simp only [list.prod_nil, list.map],
    },
    {
      cases y with y hy,
      simp only [list.prod_cons, list.map],
      simp only [list.prod_cons, subtype.coe_mk, list.map] at hxy,

      sorry,
    },
    -/
  },

end

/-
lemma eta_equalizer_iso_helper (x : pq_group Q) (hx : x ∈ ↑(eta_equalizer Q)) : of (⟨x, hx⟩ : eta_equalizer Q) = (L_of_morph of of_is_pq_morphism) (⟨x, hx⟩ : eta_equalizer Q) :=
begin

end
-/

theorem eta_equalizer_iso_helper_2 (x : pq_group (eta_equalizer Q)) : eta_equalizer_iso_backward (counit (pq_group_eta_equalizer_inclusion x)) = x :=
begin
  revert x,
  refine pq_group_word_induction _ _,
  {
    simp only [monoid_hom.map_one],
  },
  {
    intros x y hx,
    simp only [monoid_hom.map_mul, hx, mul_left_inj],
    clear hx,
    clear x,
    unfold pq_group_eta_equalizer_inclusion,
    rw L_of_morph_of,
    cases y with y hy,
    simp only,
    rw eta_equalizer_mem_def,
    swap, exact hy,
    revert y,
    refine pq_group_word_induction _ _,
    {
      intros h1,
      simp only [monoid_hom.map_one],
      rw ←of_one,
      refl,
    },
    {
      intros x y hx hxy,
      sorry,
    },
  },
end

theorem eta_equalizer_iso_helper (x : eta_equalizer Q) : eta_equalizer_iso_backward (eta_equalizer_iso_forward (of x)) = of x :=
begin
  rw eta_equalizer_iso_forward_of,
  cases x with x hx,
  simp only,
  sorry,
  /-
  revert x,
  refine pq_group_list _,
  intros x hx,
  sorry,
  -/
  /-
  refine pq_group_word_induction _ _,
  {
    intro hx,
    simp only [monoid_hom.map_one],
    rw ←of_one,
    refl,
  },
  {
    intros x y hx hxy,
    simp only [monoid_hom.map_mul],
    rw eta_equalizer_iso_backward_of,
    have hxy1 := eta_equalizer_mem_def _ hxy,
    simp only [monoid_hom.map_mul, L_of_morph_of] at hxy1,

  },
  -/
end

def eta_equalizer_iso : pq_group (eta_equalizer Q) ≃* pq_group Q := {
  to_fun := eta_equalizer_iso_forward,
  inv_fun := eta_equalizer_iso_backward,
  left_inv := begin
    refine pq_group_word_induction _ _,
    {
      simp only [monoid_hom.map_one],
    },
    {
      intros x y hx,
      simp only [monoid_hom.map_mul],
      rw hx,
      congr,
      unfold eta_equalizer_iso_forward,
      rw pq_morph_to_L_morph_adj_comm_of,
      cases y with y hy,
      simp only,
      clear hx,
      clear x,
      apply pq_group_eta_equalizer_inclusion_injective,
      rw eta_equalizer_in_sub_pq,
      clear hy,
      revert y,
      refine pq_group_word_induction _ _,
      {
        simp only [monoid_hom.map_one],
      },
      {
        intros x y hx,
        simp only [monoid_hom.map_mul],
        rw hx,
        congr,
      },
    },
  end,
  right_inv := begin
    exact eta_equalizer_iso_forward_of_backward,
  end,
  map_mul' := begin
    intros x y,
    simp only [monoid_hom.map_mul],
  end }

end pq_like_equalizer


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

import abelian
import exact
import pseudoelements
import algebra.homology.homology

open category_theory
open category_theory.limits
open cochain_complex

universes v u

namespace category_theory.abelian

open pseudoelements

section
variables {V : Type u} [𝒱 : category.{v} V] [abelian.{v} V]
include 𝒱

local attribute [instance] has_zero_object.has_zero preadditive.has_equalizers_of_has_kernels

section
variable (C : cochain_complex.{v} V)

def cokernel_to_image_map (i : ℤ) : cokernel (C.d i) ⟶ image (C.d (i + 1)) :=
cokernel.desc (C.d i) (cokernel.π (kernel.ι (C.d (i + 1))))
begin
  apply (preadditive.cancel_zero_iff_mono (factor_thru_coimage (C.d (i + 1)))).1 (by apply_instance),
  rw [category.assoc, coimage.fac, d_squared],
end

instance coker_to_im_epi {i : ℤ} : epi (cokernel_to_image_map C i) :=
epi_of_epi_fac $ show cokernel.π (C.d i) ≫ cokernel_to_image_map C i = cokernel.π (kernel.ι (C.d (i + 1))),
  by erw colimit.ι_desc; refl

def dd (i : ℤ) : cokernel (C.d i) ⟶ kernel (C.d (i + 1 + 1)) :=
cokernel_to_image_map C i ≫ image_to_kernel_map C (i + 1)

lemma exact_right (i : ℤ) : exact (dd C i) (cokernel.π (image_to_kernel_map C (i + 1))) :=
exact_left_epi _ _ _ $ cokernel_exact _

end

end

end category_theory.abelian


import algebra.module.linear_map
import algebra.module.graded_module
import ring_theory.graded_algebra.homogeneous_ideal
import ring_theory.ideal.quotient
import ring_theory.ideal.quotient_operations

import ring_theory.graded_algebra.basic
import algebra.graded_mul_action
import algebra.direct_sum.decomposition
import algebra.module.big_operators

/-!
# Graded modules over a graded ring, homogeneous submodules

This file defines a graded module (given by `ℳ : ι → submodule R M` for a `module R M`, homogeneous submodules, and operations on them (sums, intersections, quotients…)

The ring `R` is  not graded.

At the end, one adds an `graded_ring 𝒜` for `𝒜 : ι → submodule R A`, an `A`-algebra structure on `M` which is compatible with the `R`-module structure, and the multiplication is compatible with the gradings.

The case of homogeneous ideals of a graded ring follows.

WORK IN PROGRESS

Question : should there be a variant “without R” ?
Mathematically, this is equivalent with having R = ℕ,
but it may be painful to have to use `to_nat_module`…

Question : There is no reason that the indices of the grading of the ring are the same as for the module,
one should just have an `add_smul_action : ι → θ → θ`

Question : What about multiplicative weights?

-/

open set_like direct_sum set
open_locale big_operators pointwise direct_sum

variables {ι σ τ R A M : Type*}

variables [semiring R]
variables [decidable_eq ι] [add_monoid ι]
variables [add_comm_monoid M] [module R M]

-- variables [comm_ring A] [algebra R A] [module A M] [is_scalar_tower R A M]

-- variables (𝒜 : ι → submodule R A)

variable (ℳ : ι → submodule R M)

section graded_module

-- variables [set_like.graded_monoid 𝒜] [graded_ring 𝒜] [set_like.has_graded_smul 𝒜 ℳ]

-- example : set_like.has_graded_smul 𝒜 𝒜 :=
-- set_like.has_graded_mul.to_has_graded_smul 𝒜

/-  Trop lourd
 class graded_module {ι : Type*}  [decidable_eq ι] [add_monoid ι]
  {A R M : Type*}
  [comm_semiring R] [comm_semiring A] [add_comm_monoid M] [algebra R A]
  [graded_algebra 𝒜]
  [module R M] [module A M] [is_scalar_tower R A M]
  {σ : Type*} [set_like σ A] [add_submonoid_class σ A] [submodule_class σ R A] (𝒜 : ι → σ)
  {τ : Type*} [set_like τ M] [add_submonoid_class τ M] [submodule_class τ R M] (ℳ : ι → τ) :=
(to_decomposition : direct_sum.decomposition ℳ)
(to_graded_smul : set_like.has_graded_smul 𝒜 ℳ)
 -/

class graded_module {ι : Type*}  [decidable_eq ι] [add_monoid ι]
  {R M : Type*}
  [semiring R] [add_comm_monoid M]
  [module R M]
  {τ : Type*} [set_like τ M] [add_submonoid_class τ M] [submodule_class τ R M] (ℳ : ι → τ)
  extends direct_sum.decomposition ℳ

variable [graded_module ℳ]

/-- The projection maps of a graded module -/
def graded_module.proj (i : ι) : M →+ M :=
(add_submonoid_class.subtype (ℳ i)).comp ((dfinsupp.eval_add_monoid_hom i).comp $
  add_equiv.to_add_monoid_hom $ direct_sum.decompose_add_equiv ℳ)

@[simp] lemma graded_module.proj_apply (i : ι) (r : M) :
  graded_module.proj ℳ i r = (decompose ℳ r : ⨁ i, ℳ i) i := rfl

lemma graded_module.proj_recompose (r : ⨁ i, ℳ i) (i : ι) :
  graded_module.proj ℳ i ((decompose ℳ).symm r) =
  (decompose ℳ).symm (direct_sum.of _ i (r i)) :=
by rw [graded_module.proj_apply, decompose_symm_of, equiv.apply_symm_apply]

lemma graded_module.mem_support_iff [Π i (x : ℳ i), decidable (x ≠ 0)] (r : M) (i : ι) :
  i ∈ (decompose ℳ r).support ↔ graded_module.proj ℳ i r ≠ 0 :=
dfinsupp.mem_support_iff.trans zero_mem_class.coe_eq_zero.not.symm

end graded_module

section homogeneous_def

variable [graded_module ℳ]

variable {R}
/- An `N : submodule R M` is homogeneous if for every `r ∈ N`, all homogeneous components
  of `r` are in `N`. -/
def submodule.is_homogeneous [graded_module ℳ] (N : submodule R M): Prop :=
∀ (i : ι) ⦃r : M⦄, r ∈ N → (direct_sum.decompose ℳ r i : M) ∈ N

/-- For any `module R M`, we collect the homogeneous ideals of `M` into a type. -/
structure homogeneous_submodule extends submodule R M :=
(is_homogeneous' : submodule.is_homogeneous ℳ to_submodule)

variable {ℳ}

lemma homogeneous_submodule.is_homogeneous (N : homogeneous_submodule ℳ) :
  N.to_submodule.is_homogeneous ℳ := N.is_homogeneous'

lemma homogeneous_submodule.to_submodule_injective :
  function.injective (homogeneous_submodule.to_submodule : homogeneous_submodule ℳ → submodule R M) :=
λ ⟨x, hx⟩ ⟨y, hy⟩ (h : x = y), by simp [h]

instance homogeneous_submodule.set_like : set_like (homogeneous_submodule ℳ) M :=
{ coe := λ N, N.to_submodule,
  coe_injective' := λ N P h, homogeneous_submodule.to_submodule_injective $ set_like.coe_injective h }

@[ext] lemma homogeneous_submodule.ext {N P : homogeneous_submodule ℳ}
  (h : N.to_submodule = P.to_submodule) : N = P := homogeneous_submodule.to_submodule_injective h

@[simp] lemma homogeneous_submodule.mem_iff {N : homogeneous_submodule ℳ} {x : M} :
  x ∈ N.to_submodule ↔ x ∈ N := iff.rfl

end homogeneous_def

section homogeneous_core

-- variables [semiring R] [add_comm_monoid M] [module R M]
-- variables [set_like τ M]  (ℳ : ι → τ)

variable (N : submodule R M)
variable {R}
include M

/-- For any `N : submodule R M`, not necessarily homogeneous, `N.homogeneous_core' ℳ`
is the largest homogeneous submodule of `M` contained in `N`, as a submodule. -/
def submodule.homogeneous_core' (N : submodule R M) : submodule R M :=
submodule.span R (coe '' ((coe : subtype (is_homogeneous ℳ) → M) ⁻¹' N))

lemma submodule.homogeneous_core'_mono : monotone (submodule.homogeneous_core' ℳ) :=
λ N P N_le_P, submodule.span_mono $ set.image_subset _ $ λ x, @N_le_P _

lemma submodule.homogeneous_core'_le : N.homogeneous_core' ℳ ≤ N :=
submodule.span_le.2 $ image_preimage_subset _ _

end homogeneous_core

section is_homogeneous_submodule_defs

-- variables [semiring R] [add_comm_monoid M] [module R M]
-- variables [set_like τ M] [add_submonoid_class τ M] [submodule_class τ R M] (ℳ : ι → τ)
-- variables [decidable_eq ι] [add_monoid ι] [graded_module ℳ]

variable [graded_module ℳ]

variable (N : submodule R M)
variable {R}
include M

lemma submodule.is_homogeneous_iff_forall_subset :
  N.is_homogeneous ℳ ↔ ∀ i, (N : set M) ⊆ graded_module.proj ℳ i ⁻¹' N :=
iff.rfl

lemma submodule.is_homogeneous_iff_subset_Inter :
  N.is_homogeneous ℳ ↔ (N : set M) ⊆ ⋂ i, graded_module.proj ℳ i ⁻¹' ↑N :=
subset_Inter_iff.symm

/- --  Plus tard, lorsqu'il y aura un anneau gradué
lemma submodule.mul_homogeneous_element_mem_of_mem
  {I : ideal A} (r x : A) (hx₁ : is_homogeneous 𝒜 x) (hx₂ : x ∈ I) (j : ι) :
  graded_ring.proj 𝒜 j (r * x) ∈ I :=
begin
  classical,
  rw [←direct_sum.sum_support_decompose 𝒜 r, finset.sum_mul, map_sum],
  apply ideal.sum_mem,
  intros k hk,
  obtain ⟨i, hi⟩ := hx₁,
  have mem₁ : (direct_sum.decompose 𝒜 r k : A) * x ∈ 𝒜 (k + i) := graded_monoid.mul_mem
    (set_like.coe_mem _) hi,
  erw [graded_ring.proj_apply, direct_sum.decompose_of_mem 𝒜 mem₁,
    coe_of_apply, set_like.coe_mk],
  split_ifs,
  { exact I.mul_mem_left _ hx₂ },
  { exact I.zero_mem },
end -/

lemma submodule.is_homogeneous_span (s : set M) (h : ∀ x ∈ s, is_homogeneous ℳ x) :
  (submodule.span R s).is_homogeneous ℳ :=
begin
  rintros i r hr,
  rw [finsupp.span_eq_range_total, linear_map.mem_range] at hr,
  obtain ⟨f, rfl⟩ := hr,
  rw [finsupp.total_apply, finsupp.sum, decompose_sum, dfinsupp.finset_sum_apply,
    add_submonoid_class.coe_finset_sum],
  refine submodule.sum_mem _ _,
  rintros ⟨z, hz⟩ hz1,
  simp only [decompose_smul, dfinsupp.coe_smul, pi.smul_apply, submodule.coe_smul_of_tower, subtype.coe_mk],
  refine submodule.smul_mem _ _ _,
  obtain ⟨j, hzj⟩ := h z hz,
  by_cases hij : i = j,
  { rw hij,
    rw direct_sum.decompose_of_mem_same,
    exact submodule.subset_span hz,
    exact hzj },
  { rw direct_sum.decompose_of_mem_ne ℳ hzj (ne.symm hij),
    exact submodule.zero_mem _,  },
end

/--For any `N : submodule R M`, not necessarily homogeneous, `N.homogeneous_core' R ℳ`
is the largest homogeneous submodule of `M` contained in `N`.-/
def submodule.homogeneous_core : homogeneous_submodule ℳ :=
⟨submodule.homogeneous_core' ℳ N,
  submodule.is_homogeneous_span ℳ _ (λ x h,
  by { rw [subtype.image_preimage_coe, mem_inter_iff, mem_coe] at h,exact h.2, })⟩

lemma submodule.homogeneous_core_mono : monotone (submodule.homogeneous_core ℳ) :=
submodule.homogeneous_core'_mono ℳ

lemma submodule.to_submodule_homogeneous_core_le : (N.homogeneous_core ℳ).to_submodule ≤ N :=
submodule.homogeneous_core'_le ℳ N

variables {ℳ N}

lemma submodule.mem_homogeneous_core_of_is_homogeneous_of_mem {x : M}
  (h : set_like.is_homogeneous ℳ x) (hmem : x ∈ N) : x ∈ N.homogeneous_core ℳ :=
submodule.subset_span ⟨⟨x, h⟩, hmem, rfl⟩

lemma submodule.is_homogeneous.to_submodule_homogeneous_core_eq_self (h : N.is_homogeneous ℳ) :
  (N.homogeneous_core ℳ).to_submodule = N :=
begin
  apply le_antisymm (N.homogeneous_core'_le ℳ) _,
  intros x hx,
  classical,
  rw ←direct_sum.sum_support_decompose ℳ x,
  exact submodule.sum_mem _ (λ j hj, submodule.subset_span ⟨⟨_, is_homogeneous_coe _⟩, h _ hx, rfl⟩)
end

@[simp] lemma homogeneous_submodule.to_ideal_homogeneous_core_eq_self (N : homogeneous_submodule ℳ) :
  N.to_submodule.homogeneous_core ℳ = N :=
by ext1; convert submodule.is_homogeneous.to_submodule_homogeneous_core_eq_self R N.is_homogeneous

variables (ℳ N)

lemma submodule.is_homogeneous.iff_eq : N.is_homogeneous ℳ ↔ (N.homogeneous_core ℳ).to_submodule = N :=
⟨ λ hI, hI.to_submodule_homogeneous_core_eq_self,
  λ hI, hI ▸ (submodule.homogeneous_core ℳ N).2 ⟩

def homogeneous_set : set M := {m : M | is_homogeneous ℳ m}

lemma submodule.is_homogeneous.iff_exists :
  N.is_homogeneous ℳ ↔ ∃ (S : set (homogeneous_set ℳ)), N = submodule.span R (coe '' S) :=
begin
  rw [submodule.is_homogeneous.iff_eq, eq_comm],
  exact ((set.image_preimage.compose (submodule.gi _ _).gc).exists_eq_l _).symm,
end

end is_homogeneous_submodule_defs

/-! ### Operations
In this section, we show that `ideal.is_homogeneous` is preserved by various notations, then use
these results to provide these notation typeclasses for `homogeneous_ideal`. -/

section operations

section semiring

variables [semiring A] [decidable_eq ι] [add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]
include A

namespace ideal.is_homogeneous

lemma bot : ideal.is_homogeneous 𝒜 ⊥ := λ i r hr,
begin
  simp only [ideal.mem_bot] at hr,
  rw [hr, decompose_zero, zero_apply],
  apply ideal.zero_mem
end

lemma top : ideal.is_homogeneous 𝒜 ⊤ :=
λ i r hr, by simp only [submodule.mem_top]

variables {𝒜}

lemma inf {I J : ideal A} (HI : I.is_homogeneous 𝒜) (HJ : J.is_homogeneous 𝒜) :
  (I ⊓ J).is_homogeneous 𝒜 :=
λ i r hr, ⟨HI _ hr.1, HJ _ hr.2⟩

lemma sup {I J : ideal A} (HI : I.is_homogeneous 𝒜) (HJ : J.is_homogeneous 𝒜) :
  (I ⊔ J).is_homogeneous 𝒜 :=
begin
  rw iff_exists at HI HJ ⊢,
  obtain ⟨⟨s₁, rfl⟩, ⟨s₂, rfl⟩⟩ := ⟨HI, HJ⟩,
  refine ⟨s₁ ∪ s₂, _⟩,
  rw [set.image_union],
  exact (submodule.span_union _ _).symm,
end

protected lemma supr {κ : Sort*} {f : κ → ideal A} (h : ∀ i, (f i).is_homogeneous 𝒜) :
  (⨆ i, f i).is_homogeneous 𝒜 :=
begin
  simp_rw iff_exists at h ⊢,
  choose s hs using h,
  refine ⟨⋃ i, s i, _⟩,
  simp_rw [set.image_Union, ideal.span_Union],
  congr',
  exact funext hs,
end

protected lemma infi {κ : Sort*} {f : κ → ideal A} (h : ∀ i, (f i).is_homogeneous 𝒜) :
  (⨅ i, f i).is_homogeneous 𝒜 :=
begin
  intros i x hx,
  simp only [ideal.mem_infi] at ⊢ hx,
  exact λ j, h _ _ (hx j),
end

lemma supr₂ {κ : Sort*} {κ' : κ → Sort*} {f : Π i, κ' i → ideal A}
  (h : ∀ i j, (f i j).is_homogeneous 𝒜) :
  (⨆ i j, f i j).is_homogeneous 𝒜 :=
is_homogeneous.supr $ λ i, is_homogeneous.supr $ h i

lemma infi₂ {κ : Sort*} {κ' : κ → Sort*} {f : Π i, κ' i → ideal A}
  (h : ∀ i j, (f i j).is_homogeneous 𝒜) :
  (⨅ i j, f i j).is_homogeneous 𝒜 :=
is_homogeneous.infi $ λ i, is_homogeneous.infi $ h i

lemma Sup {ℐ : set (ideal A)} (h : ∀ I ∈ ℐ, ideal.is_homogeneous 𝒜 I) :
  (Sup ℐ).is_homogeneous 𝒜 :=
by { rw Sup_eq_supr, exact supr₂ h }

lemma Inf {ℐ : set (ideal A)} (h : ∀ I ∈ ℐ, ideal.is_homogeneous 𝒜 I) :
  (Inf ℐ).is_homogeneous 𝒜 :=
by { rw Inf_eq_infi, exact infi₂ h }

end ideal.is_homogeneous

variables {𝒜}

namespace homogeneous_ideal

instance : partial_order (homogeneous_ideal 𝒜) := set_like.partial_order

instance : has_top (homogeneous_ideal 𝒜) := ⟨⟨⊤, ideal.is_homogeneous.top 𝒜⟩⟩
instance : has_bot (homogeneous_ideal 𝒜) := ⟨⟨⊥, ideal.is_homogeneous.bot 𝒜⟩⟩
instance : has_sup (homogeneous_ideal 𝒜) := ⟨λ I J, ⟨_, I.is_homogeneous.sup J.is_homogeneous⟩⟩
instance : has_inf (homogeneous_ideal 𝒜) := ⟨λ I J, ⟨_, I.is_homogeneous.inf J.is_homogeneous⟩⟩
instance : has_Sup (homogeneous_ideal 𝒜) :=
⟨λ S, ⟨⨆ s ∈ S, to_ideal s, ideal.is_homogeneous.supr₂ $ λ s _, s.is_homogeneous⟩⟩
instance : has_Inf (homogeneous_ideal 𝒜) :=
⟨λ S, ⟨⨅ s ∈ S, to_ideal s, ideal.is_homogeneous.infi₂ $ λ s _, s.is_homogeneous⟩⟩

@[simp] lemma coe_top : ((⊤ : homogeneous_ideal 𝒜) : set A) = univ := rfl
@[simp] lemma coe_bot : ((⊥ : homogeneous_ideal 𝒜) : set A) = 0 := rfl
@[simp] lemma coe_sup (I J : homogeneous_ideal 𝒜) : ↑(I ⊔ J) = (I + J : set A) :=
submodule.coe_sup _ _
@[simp] lemma coe_inf (I J : homogeneous_ideal 𝒜) : (↑(I ⊓ J) : set A) = I ∩ J := rfl

@[simp] lemma to_ideal_top : (⊤ : homogeneous_ideal 𝒜).to_ideal = (⊤ : ideal A) := rfl
@[simp] lemma to_ideal_bot : (⊥ : homogeneous_ideal 𝒜).to_ideal = (⊥ : ideal A) := rfl

@[simp] lemma to_ideal_sup (I J : homogeneous_ideal 𝒜) :
  (I ⊔ J).to_ideal = I.to_ideal ⊔ J.to_ideal := rfl

@[simp] lemma to_ideal_inf (I J : homogeneous_ideal 𝒜) :
  (I ⊓ J).to_ideal = I.to_ideal ⊓ J.to_ideal := rfl

@[simp] lemma to_ideal_Sup (ℐ : set (homogeneous_ideal 𝒜)) :
  (Sup ℐ).to_ideal = ⨆ s ∈ ℐ, to_ideal s := rfl

@[simp] lemma to_ideal_Inf (ℐ : set (homogeneous_ideal 𝒜)) :
  (Inf ℐ).to_ideal = ⨅ s ∈ ℐ, to_ideal s := rfl

@[simp] lemma to_ideal_supr {κ : Sort*} (s : κ → homogeneous_ideal 𝒜) :
  (⨆ i, s i).to_ideal = ⨆ i, (s i).to_ideal :=
by rw [supr, to_ideal_Sup, supr_range]

@[simp] lemma to_ideal_infi {κ : Sort*} (s : κ → homogeneous_ideal 𝒜) :
  (⨅ i, s i).to_ideal = ⨅ i, (s i).to_ideal :=
by rw [infi, to_ideal_Inf, infi_range]

@[simp] lemma to_ideal_supr₂ {κ : Sort*} {κ' : κ → Sort*} (s : Π i, κ' i → homogeneous_ideal 𝒜) :
  (⨆ i j, s i j).to_ideal = ⨆ i j, (s i j).to_ideal :=
by simp_rw to_ideal_supr

@[simp] lemma to_ideal_infi₂ {κ : Sort*} {κ' : κ → Sort*} (s : Π i, κ' i → homogeneous_ideal 𝒜) :
  (⨅ i j, s i j).to_ideal = ⨅ i j, (s i j).to_ideal :=
by simp_rw to_ideal_infi

@[simp] lemma eq_top_iff (I : homogeneous_ideal 𝒜) : I = ⊤ ↔ I.to_ideal = ⊤ :=
to_ideal_injective.eq_iff.symm

@[simp] lemma eq_bot_iff (I : homogeneous_ideal 𝒜) : I = ⊥ ↔ I.to_ideal = ⊥ :=
to_ideal_injective.eq_iff.symm

instance : complete_lattice (homogeneous_ideal 𝒜) :=
to_ideal_injective.complete_lattice _ to_ideal_sup to_ideal_inf to_ideal_Sup to_ideal_Inf
  to_ideal_top to_ideal_bot

instance : has_add (homogeneous_ideal 𝒜) := ⟨(⊔)⟩

@[simp] lemma to_ideal_add (I J : homogeneous_ideal 𝒜) :
  (I + J).to_ideal = I.to_ideal + J.to_ideal := rfl

instance : inhabited (homogeneous_ideal 𝒜) := { default := ⊥ }

end homogeneous_ideal

end semiring

section comm_semiring
variables [comm_semiring A]
variables [decidable_eq ι] [add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] {𝒜 : ι → σ} [graded_ring 𝒜]
variable (I : ideal A)
include A

lemma ideal.is_homogeneous.mul {I J : ideal A}
  (HI : I.is_homogeneous 𝒜) (HJ : J.is_homogeneous 𝒜) : (I * J).is_homogeneous 𝒜 :=
begin
  rw ideal.is_homogeneous.iff_exists at HI HJ ⊢,
  obtain ⟨⟨s₁, rfl⟩, ⟨s₂, rfl⟩⟩ := ⟨HI, HJ⟩,
  rw ideal.span_mul_span',
  exact ⟨s₁ * s₂, congr_arg _ $ (set.image_mul (homogeneous_submonoid 𝒜).subtype).symm⟩,
end

variables {𝒜}

instance : has_mul (homogeneous_ideal 𝒜) :=
{ mul := λ I J, ⟨I.to_ideal * J.to_ideal, I.is_homogeneous.mul J.is_homogeneous⟩ }

@[simp] lemma homogeneous_ideal.to_ideal_mul (I J : homogeneous_ideal 𝒜) :
  (I * J).to_ideal = I.to_ideal * J.to_ideal := rfl

end comm_semiring

end operations

/-! ### Homogeneous core
Note that many results about the homogeneous core came earlier in this file, as they are helpful
for building the lattice structure. -/

section homogeneous_core

open homogeneous_ideal

variables [semiring A] [decidable_eq ι] [add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]
variable (I : ideal A)
include A

lemma ideal.homogeneous_core.gc : galois_connection to_ideal (ideal.homogeneous_core 𝒜) :=
λ I J, ⟨
  λ H, I.to_ideal_homogeneous_core_eq_self ▸ ideal.homogeneous_core_mono 𝒜 H,
  λ H, le_trans H (ideal.homogeneous_core'_le _ _)⟩

/--`to_ideal : homogeneous_ideal 𝒜 → ideal A` and `ideal.homogeneous_core 𝒜` forms a galois
coinsertion-/
def ideal.homogeneous_core.gi : galois_coinsertion to_ideal (ideal.homogeneous_core 𝒜) :=
{ choice := λ I HI,
    ⟨I, le_antisymm (I.to_ideal_homogeneous_core_le 𝒜) HI ▸ homogeneous_ideal.is_homogeneous _⟩,
  gc := ideal.homogeneous_core.gc 𝒜,
  u_l_le := λ I, ideal.homogeneous_core'_le _ _,
  choice_eq := λ I H, le_antisymm H (I.to_ideal_homogeneous_core_le _) }

lemma ideal.homogeneous_core_eq_Sup :
  I.homogeneous_core 𝒜 = Sup {J : homogeneous_ideal 𝒜 | J.to_ideal ≤ I} :=
eq.symm $ is_lub.Sup_eq $ (ideal.homogeneous_core.gc 𝒜).is_greatest_u.is_lub

lemma ideal.homogeneous_core'_eq_Sup :
  I.homogeneous_core' 𝒜 = Sup {J : ideal A | J.is_homogeneous 𝒜 ∧ J ≤ I} :=
begin
  refine (is_lub.Sup_eq _).symm,
  apply is_greatest.is_lub,
  have coe_mono : monotone (to_ideal : homogeneous_ideal 𝒜 → ideal A) := λ x y, id,
  convert coe_mono.map_is_greatest (ideal.homogeneous_core.gc 𝒜).is_greatest_u using 1,
  ext,
  rw [mem_image, mem_set_of_eq],
  refine ⟨λ hI, ⟨⟨x, hI.1⟩, ⟨hI.2, rfl⟩⟩, by rintro ⟨x, ⟨hx, rfl⟩⟩; exact ⟨x.is_homogeneous, hx⟩⟩,
end

end homogeneous_core

/-! ### Homogeneous hulls -/

section homogeneous_hull

open homogeneous_ideal

variables [semiring A] [decidable_eq ι] [add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]
variable (I : ideal A)
include A

/--For any `I : ideal A`, not necessarily homogeneous, `I.homogeneous_hull 𝒜` is
the smallest homogeneous ideal containing `I`. -/
def ideal.homogeneous_hull : homogeneous_ideal 𝒜 :=
⟨ideal.span {r : A | ∃ (i : ι) (x : I), (direct_sum.decompose 𝒜 (x : A) i : A) = r}, begin
  refine ideal.is_homogeneous_span _ _ (λ x hx, _),
  obtain ⟨i, x, rfl⟩ := hx,
  apply set_like.is_homogeneous_coe
end⟩

lemma ideal.le_to_ideal_homogeneous_hull :
  I ≤ (ideal.homogeneous_hull 𝒜 I).to_ideal :=
begin
  intros r hr,
  classical,
  rw [←direct_sum.sum_support_decompose 𝒜 r],
  refine ideal.sum_mem _ _, intros j hj,
  apply ideal.subset_span, use j, use ⟨r, hr⟩, refl,
end

lemma ideal.homogeneous_hull_mono : monotone (ideal.homogeneous_hull 𝒜) := λ I J I_le_J,
begin
  apply ideal.span_mono,
  rintros r ⟨hr1, ⟨x, hx⟩, rfl⟩,
  refine ⟨hr1, ⟨⟨x, I_le_J hx⟩, rfl⟩⟩,
end

variables {I 𝒜}

lemma ideal.is_homogeneous.to_ideal_homogeneous_hull_eq_self (h : I.is_homogeneous 𝒜) :
  (ideal.homogeneous_hull 𝒜 I).to_ideal = I :=
begin
  apply le_antisymm _ (ideal.le_to_ideal_homogeneous_hull _ _),
  apply (ideal.span_le).2,
  rintros _ ⟨i, x, rfl⟩,
  exact h _ x.prop,
end

@[simp] lemma homogeneous_ideal.homogeneous_hull_to_ideal_eq_self (I : homogeneous_ideal 𝒜) :
  I.to_ideal.homogeneous_hull 𝒜 = I :=
homogeneous_ideal.to_ideal_injective $ I.is_homogeneous.to_ideal_homogeneous_hull_eq_self

variables (I 𝒜)

lemma ideal.to_ideal_homogeneous_hull_eq_supr :
  (I.homogeneous_hull 𝒜).to_ideal = ⨆ i, ideal.span (graded_ring.proj 𝒜 i '' I) :=
begin
  rw ←ideal.span_Union,
  apply congr_arg ideal.span _,
  ext1,
  simp only [set.mem_Union, set.mem_image, mem_set_of_eq, graded_ring.proj_apply,
    set_like.exists, exists_prop, subtype.coe_mk, set_like.mem_coe],
end

lemma ideal.homogeneous_hull_eq_supr :
  (I.homogeneous_hull 𝒜) =
  ⨆ i, ⟨ideal.span (graded_ring.proj 𝒜 i '' I), ideal.is_homogeneous_span 𝒜 _
    (by {rintros _ ⟨x, -, rfl⟩, apply set_like.is_homogeneous_coe})⟩ :=
by { ext1, rw [ideal.to_ideal_homogeneous_hull_eq_supr, to_ideal_supr], refl }

end homogeneous_hull

section galois_connection

open homogeneous_ideal

variables [semiring A] [decidable_eq ι] [add_monoid ι]
variables [set_like σ A] [add_submonoid_class σ A] (𝒜 : ι → σ) [graded_ring 𝒜]
include A

lemma ideal.homogeneous_hull.gc : galois_connection (ideal.homogeneous_hull 𝒜) to_ideal :=
λ I J, ⟨
  le_trans (ideal.le_to_ideal_homogeneous_hull _ _),
  λ H, J.homogeneous_hull_to_ideal_eq_self ▸ ideal.homogeneous_hull_mono 𝒜 H⟩

/-- `ideal.homogeneous_hull 𝒜` and `to_ideal : homogeneous_ideal 𝒜 → ideal A` form a galois
insertion-/
def ideal.homogeneous_hull.gi : galois_insertion (ideal.homogeneous_hull 𝒜) to_ideal :=
{ choice := λ I H, ⟨I, le_antisymm H (I.le_to_ideal_homogeneous_hull 𝒜) ▸ is_homogeneous _⟩,
  gc := ideal.homogeneous_hull.gc 𝒜,
  le_l_u := λ I, ideal.le_to_ideal_homogeneous_hull _ _,
  choice_eq := λ I H, le_antisymm (I.le_to_ideal_homogeneous_hull 𝒜) H}

lemma ideal.homogeneous_hull_eq_Inf (I : ideal A) :
  ideal.homogeneous_hull 𝒜 I = Inf { J : homogeneous_ideal 𝒜 | I ≤ J.to_ideal } :=
eq.symm $ is_glb.Inf_eq $ (ideal.homogeneous_hull.gc 𝒜).is_least_l.is_glb

end galois_connection


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.linear_algebra.finite_dimensional
import Mathlib.ring_theory.integral_closure
import Mathlib.data.polynomial.integral_normalization
import Mathlib.PostPort

universes u v u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Algebraic elements and algebraic extensions

An element of an R-algebra is algebraic over R if it is the root of a nonzero polynomial.
An R-algebra is algebraic over R if and only if all its elements are algebraic over R.
The main result in this file proves transitivity of algebraicity:
a tower of algebraic field extensions is algebraic.
-/

/-- An element of an R-algebra is algebraic over R if it is the root of a nonzero polynomial. -/
def is_algebraic (R : Type u) {A : Type v} [comm_ring R] [ring A] [algebra R A] (x : A) :=
  ∃ (p : polynomial R), p ≠ 0 ∧ coe_fn (polynomial.aeval x) p = 0

/-- A subalgebra is algebraic if all its elements are algebraic. -/
def subalgebra.is_algebraic {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) :=
  ∀ (x : A), x ∈ S → is_algebraic R x

/-- An algebra is algebraic if all its elements are algebraic. -/
def algebra.is_algebraic (R : Type u) (A : Type v) [comm_ring R] [ring A] [algebra R A] :=
  ∀ (x : A), is_algebraic R x

/-- A subalgebra is algebraic if and only if it is algebraic an algebra. -/
theorem subalgebra.is_algebraic_iff {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] (S : subalgebra R A) : subalgebra.is_algebraic S ↔ algebra.is_algebraic R ↥S := sorry

/-- An algebra is algebraic if and only if it is algebraic as a subalgebra. -/
theorem algebra.is_algebraic_iff {R : Type u} {A : Type v} [comm_ring R] [ring A] [algebra R A] : algebra.is_algebraic R A ↔ subalgebra.is_algebraic ⊤ := sorry

/-- An integral element of an algebra is algebraic.-/
theorem is_integral.is_algebraic (R : Type u) {A : Type v} [comm_ring R] [nontrivial R] [ring A] [algebra R A] {x : A} (h : is_integral R x) : is_algebraic R x := sorry

/-- An element of an algebra over a field is algebraic if and only if it is integral.-/
theorem is_algebraic_iff_is_integral (K : Type u) {A : Type v} [field K] [ring A] [algebra K A] {x : A} : is_algebraic K x ↔ is_integral K x := sorry

theorem is_algebraic_iff_is_integral' (K : Type u) {A : Type v} [field K] [ring A] [algebra K A] : algebra.is_algebraic K A ↔ algebra.is_integral K A :=
  { mp := fun (h : algebra.is_algebraic K A) (x : A) => iff.mp (is_algebraic_iff_is_integral K) (h x),
    mpr := fun (h : algebra.is_integral K A) (x : A) => iff.mpr (is_algebraic_iff_is_integral K) (h x) }

namespace algebra

/-- If L is an algebraic field extension of K and A is an algebraic algebra over L,
then A is algebraic over K. -/
theorem is_algebraic_trans {K : Type u_1} {L : Type u_2} {A : Type u_3} [field K] [field L] [comm_ring A] [algebra K L] [algebra L A] [algebra K A] [is_scalar_tower K L A] (L_alg : is_algebraic K L) (A_alg : is_algebraic L A) : is_algebraic K A := sorry

/-- A field extension is algebraic if it is finite. -/
theorem is_algebraic_of_finite {K : Type u_1} {L : Type u_2} [field K] [field L] [algebra K L] [finite : finite_dimensional K L] : is_algebraic K L :=
  fun (x : L) =>
    iff.mpr (is_algebraic_iff_is_integral K)
      (is_integral_of_submodule_noetherian ⊤ (is_noetherian_of_submodule_of_noetherian K L (↑⊤) finite) x mem_top)

end algebra

theorem exists_integral_multiple {R : Type u_1} {S : Type u_2} [integral_domain R] [comm_ring S] [algebra R S] {z : S} (hz : is_algebraic R z) (inj : ∀ (x : R), coe_fn (algebra_map R S) x = 0 → x = 0) : ∃ (x : ↥(integral_closure R S)), ∃ (y : ↥(integral_closure R S)), ∃ (H : y ≠ 0), z * ↑y = ↑x := sorry

theorem inv_eq_of_aeval_div_X_ne_zero {K : Type u_3} {L : Type u_4} [field K] [field L] [algebra K L] {x : L} {p : polynomial K} (aeval_ne : coe_fn (polynomial.aeval x) (polynomial.div_X p) ≠ 0) : x⁻¹ =
  coe_fn (polynomial.aeval x) (polynomial.div_X p) /
    (coe_fn (polynomial.aeval x) p - coe_fn (algebra_map K L) (polynomial.coeff p 0)) := sorry

theorem inv_eq_of_root_of_coeff_zero_ne_zero {K : Type u_3} {L : Type u_4} [field K] [field L] [algebra K L] {x : L} {p : polynomial K} (aeval_eq : coe_fn (polynomial.aeval x) p = 0) (coeff_zero_ne : polynomial.coeff p 0 ≠ 0) : x⁻¹ = -(coe_fn (polynomial.aeval x) (polynomial.div_X p) / coe_fn (algebra_map K L) (polynomial.coeff p 0)) := sorry

theorem subalgebra.inv_mem_of_root_of_coeff_zero_ne_zero {K : Type u_3} {L : Type u_4} [field K] [field L] [algebra K L] (A : subalgebra K L) {x : ↥A} {p : polynomial K} (aeval_eq : coe_fn (polynomial.aeval x) p = 0) (coeff_zero_ne : polynomial.coeff p 0 ≠ 0) : ↑x⁻¹ ∈ A := sorry

theorem subalgebra.inv_mem_of_algebraic {K : Type u_3} {L : Type u_4} [field K] [field L] [algebra K L] (A : subalgebra K L) {x : ↥A} (hx : is_algebraic K ↑x) : ↑x⁻¹ ∈ A := sorry

/-- In an algebraic extension L/K, an intermediate subalgebra is a field. -/
theorem subalgebra.is_field_of_algebraic {K : Type u_3} {L : Type u_4} [field K] [field L] [algebra K L] (A : subalgebra K L) (hKL : algebra.is_algebraic K L) : is_field ↥A := sorry


/-
Copyright (c) 2022 Eric Rodriguez. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Rodriguez, Eric Wieser

! This file was ported from Lean 3 source module data.list.destutter
! leanprover-community/mathlib commit f2f413b9d4be3a02840d0663dace76e8fe3da053
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.List.Chain

/-!
# Destuttering of Lists

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

This file proves theorems about `list.destutter` (in `data.list.defs`), which greedily removes all
non-related items that are adjacent in a list, e.g. `[2, 2, 3, 3, 2].destutter (≠) = [2, 3, 2]`.
Note that we make no guarantees of being the longest sublist with this property; e.g.,
`[123, 1, 2, 5, 543, 1000].destutter (<) = [123, 543, 1000]`, but a longer ascending chain could be
`[1, 2, 5, 543, 1000]`.

## Main statements

* `list.destutter_sublist`: `l.destutter` is a sublist of `l`.
* `list.destutter_is_chain'`: `l.destutter` satisfies `chain' R`.
* Analogies of these theorems for `list.destutter'`, which is the `destutter` equivalent of `chain`.

## Tags

adjacent, chain, duplicates, remove, list, stutter, destutter
-/

variable {α : Type _} (l : List α) (R : α → α → Prop) [DecidableRel R] {a b : α}

namespace List

#print List.destutter'_nil /-
@[simp]
theorem destutter'_nil : destutter' R a [] = [a] :=
  rfl
#align list.destutter'_nil List.destutter'_nil
-/

#print List.destutter'_cons /-
theorem destutter'_cons :
    (b :: l).destutter' R a = if R a b then a :: destutter' R b l else destutter' R a l :=
  rfl
#align list.destutter'_cons List.destutter'_cons
-/

variable {R}

#print List.destutter'_cons_pos /-
@[simp]
theorem destutter'_cons_pos (h : R b a) : (a :: l).destutter' R b = b :: l.destutter' R a := by
  rw [destutter', if_pos h]
#align list.destutter'_cons_pos List.destutter'_cons_pos
-/

#print List.destutter'_cons_neg /-
@[simp]
theorem destutter'_cons_neg (h : ¬R b a) : (a :: l).destutter' R b = l.destutter' R b := by
  rw [destutter', if_neg h]
#align list.destutter'_cons_neg List.destutter'_cons_neg
-/

variable (R)

#print List.destutter'_singleton /-
@[simp]
theorem destutter'_singleton : [b].destutter' R a = if R a b then [a, b] else [a] := by
  split_ifs <;> simp! [h]
#align list.destutter'_singleton List.destutter'_singleton
-/

#print List.destutter'_sublist /-
theorem destutter'_sublist (a) : l.destutter' R a <+ a :: l :=
  by
  induction' l with b l hl generalizing a
  · simp
  rw [destutter']
  split_ifs
  · exact sublist.cons2 _ _ _ (hl b)
  · exact (hl a).trans ((l.sublist_cons b).cons_cons a)
#align list.destutter'_sublist List.destutter'_sublist
-/

#print List.mem_destutter' /-
theorem mem_destutter' (a) : a ∈ l.destutter' R a :=
  by
  induction' l with b l hl
  · simp
  rw [destutter']
  split_ifs
  · simp
  · assumption
#align list.mem_destutter' List.mem_destutter'
-/

#print List.destutter'_is_chain /-
theorem destutter'_is_chain : ∀ l : List α, ∀ {a b}, R a b → (l.destutter' R b).Chain R a
  | [], a, b, h => chain_singleton.mpr h
  | c :: l, a, b, h => by
    rw [destutter']
    split_ifs with hbc
    · rw [chain_cons]
      exact ⟨h, destutter'_is_chain l hbc⟩
    · exact destutter'_is_chain l h
#align list.destutter'_is_chain List.destutter'_is_chain
-/

#print List.destutter'_is_chain' /-
theorem destutter'_is_chain' (a) : (l.destutter' R a).Chain' R :=
  by
  induction' l with b l hl generalizing a
  · simp
  rw [destutter']
  split_ifs
  · exact destutter'_is_chain R l h
  · exact hl a
#align list.destutter'_is_chain' List.destutter'_is_chain'
-/

#print List.destutter'_of_chain /-
theorem destutter'_of_chain (h : l.Chain R a) : l.destutter' R a = a :: l :=
  by
  induction' l with b l hb generalizing a
  · simp
  obtain ⟨h, hc⟩ := chain_cons.mp h
  rw [l.destutter'_cons_pos h, hb hc]
#align list.destutter'_of_chain List.destutter'_of_chain
-/

#print List.destutter'_eq_self_iff /-
@[simp]
theorem destutter'_eq_self_iff (a) : l.destutter' R a = a :: l ↔ l.Chain R a :=
  ⟨fun h => by
    rw [← chain', ← h]
    exact l.destutter'_is_chain' R a, destutter'_of_chain _ _⟩
#align list.destutter'_eq_self_iff List.destutter'_eq_self_iff
-/

#print List.destutter'_ne_nil /-
theorem destutter'_ne_nil : l.destutter' R a ≠ [] :=
  ne_nil_of_mem <| l.mem_destutter' R a
#align list.destutter'_ne_nil List.destutter'_ne_nil
-/

#print List.destutter_nil /-
@[simp]
theorem destutter_nil : ([] : List α).destutter R = [] :=
  rfl
#align list.destutter_nil List.destutter_nil
-/

#print List.destutter_cons' /-
theorem destutter_cons' : (a :: l).destutter R = destutter' R a l :=
  rfl
#align list.destutter_cons' List.destutter_cons'
-/

#print List.destutter_cons_cons /-
theorem destutter_cons_cons :
    (a :: b :: l).destutter R = if R a b then a :: destutter' R b l else destutter' R a l :=
  rfl
#align list.destutter_cons_cons List.destutter_cons_cons
-/

#print List.destutter_singleton /-
@[simp]
theorem destutter_singleton : destutter R [a] = [a] :=
  rfl
#align list.destutter_singleton List.destutter_singleton
-/

#print List.destutter_pair /-
@[simp]
theorem destutter_pair : destutter R [a, b] = if R a b then [a, b] else [a] :=
  destutter_cons_cons _ R
#align list.destutter_pair List.destutter_pair
-/

#print List.destutter_sublist /-
theorem destutter_sublist : ∀ l : List α, l.destutter R <+ l
  | [] => Sublist.slnil
  | h :: l => l.destutter'_sublist R h
#align list.destutter_sublist List.destutter_sublist
-/

#print List.destutter_is_chain' /-
theorem destutter_is_chain' : ∀ l : List α, (l.destutter R).Chain' R
  | [] => List.chain'_nil
  | h :: l => l.destutter'_is_chain' R h
#align list.destutter_is_chain' List.destutter_is_chain'
-/

#print List.destutter_of_chain' /-
theorem destutter_of_chain' : ∀ l : List α, l.Chain' R → l.destutter R = l
  | [], h => rfl
  | a :: l, h => l.destutter'_of_chain _ h
#align list.destutter_of_chain' List.destutter_of_chain'
-/

#print List.destutter_eq_self_iff /-
@[simp]
theorem destutter_eq_self_iff : ∀ l : List α, l.destutter R = l ↔ l.Chain' R
  | [] => by simp
  | a :: l => l.destutter'_eq_self_iff R a
#align list.destutter_eq_self_iff List.destutter_eq_self_iff
-/

#print List.destutter_idem /-
theorem destutter_idem : (l.destutter R).destutter R = l.destutter R :=
  destutter_of_chain' R _ <| l.destutter_is_chain' R
#align list.destutter_idem List.destutter_idem
-/

#print List.destutter_eq_nil /-
@[simp]
theorem destutter_eq_nil : ∀ {l : List α}, destutter R l = [] ↔ l = []
  | [] => Iff.rfl
  | a :: l => ⟨fun h => absurd h <| l.destutter'_ne_nil R, fun h => nomatch h⟩
#align list.destutter_eq_nil List.destutter_eq_nil
-/

end List


import algebra.homology.homological_complex

open category_theory category_theory.limits

namespace homological_complex

universes w' w v v' u u'

variables {V : Type u} [category.{v} V] {J : Type w} [category.{w'} J]
variables {ι : Type u'} {c : complex_shape ι}

-- move this
section
variables {C : Type u} [category.{v} C] {Z : C → Prop}
@[simps]
def lift_iso {X Y : full_subcategory Z} (h : X.obj ≅ Y.obj) : X ≅ Y :=
{ hom := h.hom, inv := h.inv, hom_inv_id' := h.hom_inv_id, inv_hom_id' := h.inv_hom_id }
end

section walking_complex

@[nolint unused_arguments]
def walking_complex (c : complex_shape ι) := ι

inductive walking_complex_hom : walking_complex c → walking_complex c → Type u'
| id : Π i, walking_complex_hom i i
| d : Π {i j}, c.rel i j → walking_complex_hom i j
| zero : Π i j, walking_complex_hom i j

section

open walking_complex_hom

def walking_complex_hom_comp (i j k : walking_complex c) :
  walking_complex_hom i j → walking_complex_hom j k → walking_complex_hom i k :=
begin
  intros f g,
  cases f with _ _ _ r,
  { exact g },
  { cases g, exacts [walking_complex_hom.d r, walking_complex_hom.zero _ _, walking_complex_hom.zero _ _] },
  { exact walking_complex_hom.zero _ _ },
end

instance : category_struct (walking_complex c) :=
{ hom := walking_complex_hom,
  id := walking_complex_hom.id,
  comp :=
  begin
    intros i j k f g,
    cases f with _ _ _ r,
    { exact g },
    { cases g, exacts [walking_complex_hom.d r, walking_complex_hom.zero _ _, walking_complex_hom.zero _ _] },
    { exact walking_complex_hom.zero _ _ },
  end }
end

local attribute [tidy] tactic.case_bash

instance : category (walking_complex c) := {}
.

instance walking_complex_hom_has_zero (i j : walking_complex c) : has_zero (i ⟶ j) :=
⟨walking_complex_hom.zero i j⟩

instance : has_zero_morphisms (walking_complex c) := {}
.

@[simp] lemma walking_complex_hom_id (i : walking_complex c) : walking_complex_hom.id i = 𝟙 i :=
rfl
@[simp] lemma walking_complex_hom_zero (i : walking_complex c) : walking_complex_hom.zero i = 0 :=
rfl

def walking_complex_d {i j : walking_complex c} (r : c.rel i j) : i ⟶ j :=
  walking_complex_hom.d r

@[simp] lemma walking_complex_d_eq {i j : walking_complex c} (r : c.rel i j) :
  walking_complex_hom.d r = walking_complex_d r := rfl

@[simp] lemma walking_complex_hom_d_comp_d {i j k : walking_complex c}
  (r : c.rel i j) (r' : c.rel j k) : walking_complex_d r ≫ walking_complex_d r' = 0 := rfl

variable [has_zero_morphisms V]

def complex_to_functor_map
  (h : homological_complex V c) {i j : walking_complex c} (f : i ⟶ j) : h.X i ⟶ h.X j :=
begin
  cases f, exacts [𝟙 _, h.d _ _, 0]
end

@[simp]
lemma complex_to_functor_map_id
  (h : homological_complex V c) (i : walking_complex c) : complex_to_functor_map h (𝟙 i) = 𝟙 _ :=
rfl

@[simp]
lemma complex_to_functor_map_zero
  (h : homological_complex V c) (i j : walking_complex c) :
    complex_to_functor_map h (0 : i ⟶ j) = 0 :=
rfl

@[simp]
lemma complex_to_functor_map_d
  (h : homological_complex V c) {i j : walking_complex c} (r : c.rel i j) :
    complex_to_functor_map h (walking_complex_d r) = h.d _ _ := rfl

@[simps]
def complex_to_functor (h : homological_complex V c) :
  walking_complex c ⥤ V :=
{ obj := h.X, map := λ i j f, complex_to_functor_map h f }
.

variable [decidable_rel c.rel]

@[simps]
def functor_to_complex (F : walking_complex c ⥤ V)
  (hF : ∀ i j, F.map (0 : i ⟶ j) = 0) :
  homological_complex V c :=
{ X := F.obj,
  d := λ i j, if r : c.rel i j then F.map (walking_complex_d r) else 0,
  d_comp_d' := by { introv r r',
    rw [dif_pos r, dif_pos r', ← F.map_comp, walking_complex_hom_d_comp_d, hF] } }
.
variables (c V)

@[simps]
def complex_to_functor_functor :
  homological_complex V c ⥤ full_subcategory (λ F : walking_complex c ⥤ V, ∀ i j, F.map (0 : i ⟶ j) = 0) :=
{ obj := λ X, ⟨complex_to_functor X, λ _ _, rfl⟩, map := λ X Y f, { app := f.f } }

@[simps]
def functor_to_complex_functor :
  full_subcategory (λ F : walking_complex c ⥤ V, ∀ i j, F.map (0 : i ⟶ j) = 0) ⥤ homological_complex V c :=
{ obj := λ F, functor_to_complex F.1 F.2,
  map := λ F G f, { f := f.app, comm' := by { intros i j r, simp [dif_pos r] } } }
.

@[simps]
def complex_equiv_functor_unit :
  𝟭 _ ≅ complex_to_functor_functor V c ⋙ functor_to_complex_functor V c :=
nat_iso.of_components
  (λ X, hom.iso_of_components (λ i, iso.refl _) (by { introv r, dsimp, simp [if_pos r] }))
  (by { intros, ext, dsimp, simp })

@[simps]
def complex_equiv_functor_counit :
  functor_to_complex_functor V c ⋙ complex_to_functor_functor V c ≅ 𝟭 _ :=
nat_iso.of_components
  (λ F, lift_iso $ nat_iso.of_components (λ i, iso.refl _)
    (by { introv, cases F with F hF, cases f; dsimp; simp [*, hF] }))
  (by { introv, ext, dsimp, erw [nat_trans.comp_app, nat_trans.comp_app], dsimp, simp })

@[simps]
def complex_equiv_functor :
  homological_complex V c ≌ full_subcategory (λ F : walking_complex c ⥤ V, ∀ i j, F.map (0 : i ⟶ j) = 0) :=
{ functor := complex_to_functor_functor V c,
  inverse := functor_to_complex_functor V c,
  unit_iso := complex_equiv_functor_unit V c,
  counit_iso := complex_equiv_functor_counit V c,
  functor_unit_iso_comp' :=
    by { intro x, ext, erw [nat_trans.comp_app, nat_trans.id_app], dsimp, simp } }
.

instance : is_equivalence (complex_to_functor_functor V c) :=
is_equivalence.of_equivalence (complex_equiv_functor V c)
instance : is_equivalence (functor_to_complex_functor V c) :=
is_equivalence.of_equivalence_inverse (complex_equiv_functor V c)

@[simps, derive [full, faithful]]
def complex_to_functor_category_functor : homological_complex V c ⥤ walking_complex c ⥤ V :=
complex_to_functor_functor V c ⋙ induced_functor _

end walking_complex

section walking_preadditive_complex

/-
TODO : If `V` is preadditive, then the cateogory of homological complexes is equivalent to the
category of additive functors from a preadditive category `walking_preadditive_complex` to `V`.
-/

end walking_preadditive_complex

end homological_complex