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

variables {ι : Type} {M : ι → Type}
variables [decidable_eq ι] [Π i, decidable_eq (M i)]
variables [Π i, monoid (M i)]

open list

section partial_prod

open coprod

/-- `partial_prod l` returns the list of products of final segments of `l`.
  e.g. `partial_prod [a, b, c]` = `[a * b * c, b * c, c]`  -/
def list.partial_prod {M : Type*} [monoid M] : list M → list M
| []     := []
| (a::l) := (a::l : list _).prod :: list.partial_prod l

lemma prod_mem_partial_prod {M : Type*} [monoid M] (l : list M) :
  l = [] ∨ l.prod ∈ l.partial_prod :=
by cases l; simp [list.partial_prod]

lemma partial_prod_append {M : Type*} [monoid M] (l₁ l₂ : list M) :
  (l₁ ++ l₂).partial_prod = l₁.partial_prod.map (* l₂.prod) ++ l₂.partial_prod :=
by induction l₁; simp [list.partial_prod, *, mul_assoc]

def list.partial_prod' {M : Type*} [monoid M] : list M → list M
| []     := [1]
| (a::l) := (a::l : list _).prod :: list.partial_prod' l

lemma partial_prod'_eq_partial_prod_append {M : Type*} [monoid M] (l : list M) :
  l.partial_prod' = l.partial_prod ++ [1] :=
by induction l; simp [*, list.partial_prod, list.partial_prod'] at *

def partial_prod'_concat {M : Type*} [monoid M] (l : list M) (a : M) :
  (l ++ [a]).partial_prod' = l.partial_prod'.map (* a) ++ [1] :=
by induction l; simp [list.partial_prod', mul_assoc, *]

lemma partial_prod'_reverse_inv {G : Type*} [group G] (l : list G) :
  ((l: list _).map has_inv.inv).reverse.partial_prod' =
  (l : list _).partial_prod'.reverse.map (λ x, x * l.prod⁻¹) :=
begin
  induction l with g l ih,
  { simp [list.partial_prod', mul_assoc] },
  { simp [list.partial_prod', partial_prod'_concat, ih,
      function.comp, mul_assoc] }
end

lemma mem_partial_prod_reverse_inv {G : Type*} [group G] {l : list G} {x : G} (hx : x ≠ 1) :
  x ∈ ((l: list _).map has_inv.inv).reverse.partial_prod ↔
    x ∈ (l : list _).partial_prod.map (λ x, x * l.prod⁻¹) ∨ x = l.prod⁻¹ :=
begin
  have := congr_arg ((∈) x) (partial_prod'_reverse_inv l),
  simp only [partial_prod'_eq_partial_prod_append, list.mem_append,
    list.mem_singleton, hx, or_false, list.mem_reverse,
    list.map_reverse, list.map_append] at this,
  rw this,
  simp
end

lemma partial_prod_sublist_aux₁ (i : ι) (a : M i) :
  ∀ (l : list (Σ i, M i)) (hl : pre.reduced l),
  ((of i a * ⟨l, hl⟩).to_list.map (λ i : Σ i, M i, of i.1 i.2)).partial_prod <+
    (of i a * (l.map (λ i : Σ i, M i, of i.1 i.2)).prod) :: (l.map (λ i : Σ i, M i, of i.1 i.2)).partial_prod
| [] hl := by simp [list.partial_prod, to_list_of];
  split_ifs; simp [list.partial_prod]
| (⟨j, b⟩::l) hl := begin
  rw [of_mul_cons],
  split_ifs,
  { simp only [h, monoid_hom.map_one, one_mul, coprod.to_list],
    exact list.sublist_cons _ _ },
  { subst j,
    simp only [coprod.to_list, list.map_cons, list.partial_prod],
    exact list.sublist.trans (list.sublist_cons _ _)
      (list.sublist_cons _ _) },
  { subst j,
    simp only [coprod.to_list, list.map_cons,
      list.partial_prod, list.prod_cons, cast_eq],
    dsimp,
    simp only [monoid_hom.map_mul, mul_assoc],
    apply list.sublist.cons2,
    apply list.sublist_cons },
  { simp only [coprod.to_list, list.map_cons,
      list.partial_prod, list.prod_cons, cast_eq] }
end

lemma lift_eq_map_prod {N : Type*} [monoid N] (f : Π i, M i →* N)
  (w : coprod M) : lift f w = (w.to_list.map (λ i : Σ i, M i, f i.1 i.2)).prod :=
pre.lift_eq_map_prod _ _

@[simp] lemma lift_hom_of : coprod.lift (of : Π i : ι, M i →* coprod M) =
  monoid_hom.id _ :=
coprod.hom_ext (by simp)

@[simp] lemma map_prod_of_eq_self (w : coprod M) :
  (w.to_list.map (λ i : Σ i, M i, of i.1 i.2)).prod = w :=
by rw [← lift_eq_map_prod, lift_hom_of, monoid_hom.id_apply]

lemma partial_prod_sublist_aux₂ (i : ι) (a : M i) (w : coprod M) :
  ((of i a * w).to_list.map (λ i : Σ i, M i, of i.1 i.2)).partial_prod <+
    (of i a * w) :: (w.to_list.map (λ i : Σ i, M i, of i.1 i.2)).partial_prod :=
begin
  cases w with l hl,
  convert partial_prod_sublist_aux₁ i a l hl,
  conv_lhs { rw [← map_prod_of_eq_self ⟨l, hl⟩] },
  refl
end

lemma partial_prod_sublist : ∀ (l : list (Σ i, M i)),
  ((l.map (λ i : Σ i, M i, of i.1 i.2)).prod.to_list.map
    (λ i : Σ i, M i, of i.1 i.2)).partial_prod <+
    (l.map (λ i : Σ i, M i, of i.1 i.2)).partial_prod
| []     := by simp [list.partial_prod]
| [i]    := begin
    simp [list.partial_prod, to_list_of],
    split_ifs;
    simp [list.partial_prod]
  end
| (i::l) := begin
  rw [list.map_cons, list.prod_cons, list.partial_prod],
  apply list.sublist.trans (partial_prod_sublist_aux₂ i.1 i.2 (l.map (λ i : Σ i, M i, of i.1 i.2)).prod),
  simp only [list.prod_cons, map_prod_of_eq_self],
  apply list.sublist.cons2,
  exact partial_prod_sublist _
end

end partial_prod

open free_group

@[reducible] def fprod (l : list (Σ i : ι, C∞)) : free_group ι :=
(l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)).prod

@[reducible] def fpprod (l : list (Σ i : ι, C∞)) : list (free_group ι) :=
(l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)).partial_prod

lemma mem_blah_iff_partial_prod_mem_blah (S : ι → subgroup C∞) (w : free_group ι) :
  (∀ v : free_group ι, v ∈ fpprod w.to_list → v ∈ blah S)
  ↔ w ∈ blah S :=
begin
  cases w with l hl,
  induction l with i l ih,
  { simp [list.partial_prod, subgroup.one_mem, fpprod] },
  { simp only [list.partial_prod, coprod.to_list_mk, list.map_cons,
      list.mem_cons_iff, list.prod_cons],
    split,
    { assume hv,
      refine hv _ (or.inl _),
      rw [coprod.cons_eq_of_mul, ← map_prod_of_eq_self
        ⟨l, coprod.pre.reduced_of_reduced_cons hl⟩],
      simp [of'] },
    { intros h v hv,
      rcases hv with rfl | hv,
      { convert h,
        rw [← map_prod_of_eq_self ⟨i :: l, hl⟩, coprod.to_list],
        simp [of'] },
      { refine (ih (coprod.pre.reduced_of_reduced_cons hl)).2 _ _ hv,
        { assume j hj, exact h j (list.mem_cons_of_mem _ hj) } } } }
end

def pow_single (t : ι) (n : C∞) : free_group ι →* free_group ι :=
free_group.lift (λ i, if t = i then free_group.of' i n else free_group.of i)

lemma exp_sum_comp_pow_single (t : ι) (n : C∞) :
  (exp_sum t).comp (pow_single t n) = (gpowers_hom _ n).comp (exp_sum t) :=
hom_ext (λ i, begin
  simp [pow_single, exp_sum, of_eq_of', free_group.lift],
  split_ifs,
  { simp [*, gpowers_hom] },
  { simp [*, gpowers_hom] }
end)

lemma range_pow_single (t : ι) (n : C∞) : (pow_single t n).range =
  blah (λ i : ι, show subgroup C∞, from ⨅ (h : t = i), subgroup.gpowers n) :=
begin
  rw [blah_eq_supr, pow_single, range_lift],
  refine le_antisymm
    ((subgroup.closure_le _).2 (set.range_subset_iff.2 _))
    (supr_le _),
  { assume i,
    have := le_supr (λ i : ι, show subgroup (free_group ι), from subgroup.map (of' i)
      (show subgroup C∞, from ⨅ (h : t = i), subgroup.gpowers n)) i,
    rw [subgroup.le_def] at this,
    refine this _,
    split_ifs,
    { subst i,
      exact subgroup.mem_map.2 ⟨_, by simp, rfl⟩ },
    { exact subgroup.mem_map.2 ⟨multiplicative.of_add 1, by simp [h], rfl⟩ } },
  { assume i,
    refine subgroup.map_le_iff_le_comap.2 (λ m hm, _),
    by_cases h : t = i,
    { rw [h, eq_self_iff_true, infi_true] at hm,
      rcases hm with ⟨k, rfl⟩,
      refine subgroup.gpow_mem _ (subgroup.mem_comap.2 _) _,
      refine subgroup.subset_closure (set.mem_range.2 ⟨i, _⟩),
      simp * },
    { refine subgroup.mem_comap.2 _,
      rw [of'_eq_of_pow],
      refine subgroup.gpow_mem _ _ _,
      refine subgroup.subset_closure (set.mem_range.2 ⟨i, _⟩),
      simp * } }
end

open multiplicative

def eliminate_t (t : ι) (n : C∞) : list (Σ i : ι, C∞) → list (Σ i : option ι, C∞) × C∞
| []          := ([], 1)
| (i::l) :=
let x := eliminate_t l in
if t = i.1
  then if n.to_add ∣ to_add i.2 + to_add x.2
    then (⟨none, of_add ((to_add i.2 + to_add x.2) / n.to_add)⟩ ::
      ⟨some i.1, x.2⁻¹⟩ :: x.1, 1)
    else (⟨some i.1, i.2⟩ :: x.1, i.2 * x.2)
  else (⟨some i.1, i.2⟩ :: x.1, x.2)

lemma eliminate_t_snd (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
  (eliminate_t t n l).2 = exp_sum (some t) (fprod (eliminate_t t n l).1) :=
begin
  induction l,
  { simp [eliminate_t, fprod] },
  { simp only [eliminate_t, exp_sum, l_ih],
    split_ifs at *; simp [*, fprod] }
end

lemma eliminate_t_snd_eq_one (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
  to_add n ∣ (eliminate_t t n l).snd.to_add → (eliminate_t t n l).snd = 1 :=
begin
  induction l with i l ih,
  { simp [eliminate_t] },
  { cases i with i a,
    dsimp only [eliminate_t],
    split_ifs; finish }
end

lemma eliminate_t_exp_sum_eq_one (t : ι) (n : C∞) (l : list (Σ i : ι, C∞))
  (w : free_group (option ι))
  (hw : w ∈ fpprod (eliminate_t t n l).1)
  (hdvd : to_add n ∣ (exp_sum (some t) w).to_add) :
  exp_sum (some t) w = 1 :=
begin
  induction l with i l ih generalizing w,
  { simp [*, list.partial_prod, eliminate_t, fpprod] at * },
  { cases i with i a,
    dsimp only [eliminate_t, fpprod] at hw,
    split_ifs at hw,
    { subst h,
      rw [list.map_cons, list.partial_prod, list.map_cons, list.partial_prod,
        list.mem_cons_iff, list.mem_cons_iff] at hw,
      rcases hw with rfl | rfl| hw,
      { simp [eliminate_t_snd] },
      { simp [eliminate_t_snd] },
      { exact ih _ hw hdvd } },
    { subst h,
      rw [list.map_cons, list.partial_prod, list.mem_cons_iff] at hw,
      rcases hw with rfl | hw,
      { simp [eliminate_t_snd, *] at * },
      { exact ih _ hw hdvd } },
    { rw [list.map_cons, list.partial_prod, list.mem_cons_iff] at hw,
      rcases hw with rfl | hw,
      { simp [eliminate_t_snd, h],
        cases prod_mem_partial_prod ((eliminate_t t n l).1.map
            (λ i : Σ i : option ι, C∞, of' i.1 i.2)) with he he,
        { rw he, simp [subgroup.one_mem] },
        { refine ih _ he _,
          simpa [list.map_cons, h] using hdvd } },
      { exact ih _ hw hdvd } } }
end

lemma prod_eliminate_t (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) (hn : n ≠ 1) :
  lift (λ i : option ι, i.elim (of' t n) of) (fprod (eliminate_t t n l).1) = fprod l :=
begin
  dsimp only [fprod] at *,
  induction l with  i l ih,
  { simp [eliminate_t] },
  { rw [eliminate_t],
    split_ifs,
    { cases h_1 with k hk,
      rw [int.div_eq_of_eq_mul_right (show n.to_add ≠ 0, from hn) hk, list.map_cons, list.map_cons,
        list.map_cons, list.prod_cons, list.prod_cons, list.prod_cons, ← ih],
      simp only [of'_eq_of_pow, monoid_hom.map_gpow, h, monoid_hom.map_list_prod,
        function.comp, lift_of, option.elim, monoid_hom.map_mul,
        to_add_of_add, monoid_hom.map_inv, list.map_map, ← mul_assoc,
        ← gpow_add, ← gpow_neg, ← gpow_mul, ← hk],
      simp },
    { rw [list.map_cons, list.prod_cons, monoid_hom.map_mul, ih],
      simp [of'_eq_of_pow, monoid_hom.map_gpow] },
    { rw [list.map_cons, list.prod_cons, monoid_hom.map_mul, ih],
      simp [of'_eq_of_pow, monoid_hom.map_gpow] } }
end

lemma exp_sum_eq_one_of_mem_closure_var {t : ι} {w : free_group ι} {s : set ι}
  (hw : w ∈ closure_var s) (his : t ∉ s) : exp_sum t w = 1 :=
begin
  cases w with l hl,
  induction l with i l ih,
  { simp },
  { rw [cons_eq_of'_mul, monoid_hom.map_mul, exp_sum_of'],
    have := hw i (list.mem_cons_self _ _),
    have hit : t ≠ i.1,
    { assume hit,
      subst hit,
      have := hl.2 i (list.mem_cons_self _ _),
      simp * at * },
    rw [if_neg hit, one_mul],
    exact ih (coprod.pre.reduced_of_reduced_cons _)
      (λ i hi, hw _ (list.mem_cons_of_mem _ hi)) }
end

lemma mem_closure_var_of_forall_exp_sum_eq_one_aux {t : ι} {l : list (Σ i : ι, C∞)}
  (h : ∀ w, w ∈ fpprod l → exp_sum t w = 1) : fprod l ∈ closure_var {i | t ≠ i} :=
begin
  induction l with i l ih,
  { simp [subgroup.one_mem, fprod] },
  { rw [fprod, list.map_cons, list.prod_cons],
    simp only [list.partial_prod, list.map_cons, fpprod] at h,
    have := h _ (list.mem_cons_self _ _),
    simp at this,
    refine subgroup.mul_mem _ _ _,
    { split_ifs at this,
      { cases prod_mem_partial_prod (l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)) with he he,
        { rw he at this,
          simp [*, subgroup.one_mem] at * },
        { rw [h _ (list.mem_cons_of_mem _ he), mul_one] at this,
          simp [this, subgroup.one_mem] } },
      { rw [closure_var, of'_mem_blah_iff],
        simp [h_1] } },
    { exact ih (λ w hw, h w (list.mem_cons_of_mem _ hw)) } }
end

lemma mem_closure_var_of_forall_exp_sum_eq_one {t : ι} {w : free_group ι}
  (h : ∀ v, v ∈ fpprod w.to_list → exp_sum t v = 1) : w ∈ closure_var {i | t ≠ i} :=
begin
  convert mem_closure_var_of_forall_exp_sum_eq_one_aux h,
  simp only [of', map_prod_of_eq_self, fprod]
end

lemma partial_prod_mem_blah {S : ι → subgroup C∞} {w v : free_group ι}
  (hv : v ∈ fpprod w.to_list) (hw : w ∈ blah S) : v ∈ blah S :=
begin
  cases w with l hl,
  induction l with i l ih,
  { simp [*, fpprod, list.partial_prod] at * },
  { rw [fpprod, coprod.to_list, list.map_cons, list.partial_prod, list.mem_cons_iff] at hv,
    rcases hv with rfl | hv,
    { erw [list.prod_cons, map_prod_of_eq_self ⟨l, coprod.pre.reduced_of_reduced_cons hl⟩],
      refine subgroup.mul_mem _
        (by simp [of'_mem_blah_iff, hw _ (list.mem_cons_self  _ _)])
        (λ i hi, hw _ (list.mem_cons_of_mem _ hi)) },
    { exact ih (coprod.pre.reduced_of_reduced_cons hl) hv
        (λ i hi, hw _ (list.mem_cons_of_mem _ hi)) } }
end

lemma append_exp_sum_eq_one {n : C∞} {t : ι} {l₁ : list (Σ i : ι, C∞)} {r : free_group ι}
  (h₁ : r ∈ closure_var {i | i ≠ t})
  (h₂ : ∀ v, v ∈ fpprod l₁ → n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1) :
  ∀ v ∈ fpprod (l₁ ++ r.to_list), n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1 :=
begin
  assume v hv hn,
  simp only [fpprod, partial_prod_append, list.map_append, list.mem_append] at hv,
  cases hv with hv hv,
  { rcases list.mem_map.1 hv with ⟨w, hw, rfl⟩,
    { erw [monoid_hom.map_mul, map_prod_of_eq_self,
        exp_sum_eq_one_of_mem_closure_var h₁ (by simp), mul_one] at ⊢ hn,
      rw [h₂ _ hw hn] } },
  { exact exp_sum_eq_one_of_mem_closure_var (partial_prod_mem_blah hv h₁) (by simp) }
end

lemma exp_sum_append_subset {t : ι} {l : list (Σ i : ι, C∞)} {r : free_group ι}
  (h₁ : r ∈ closure_var {i | i ≠ t}) :
  ∀ v ∈ fpprod ((l.map (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse ++ r.to_list ++ l),
    exp_sum t v ≠ 1 → (∃ w ∈ fpprod l, exp_sum t v = exp_sum t w) :=
begin
  assume v hv hv1,
  simp only [fpprod, partial_prod_append, function.comp,
    list.map_append, list.mem_append, or.assoc] at hv,
  rw [← fpprod, ← fpprod, ← fpprod, ← fprod, ← fprod] at hv,
  rcases hv with hv | hv | hv,
  { rw [list.map_map, list.mem_map] at hv,
    rcases hv with ⟨w, hw, rfl⟩,
    have hw' : w ∈ ((l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)).map has_inv.inv).reverse.partial_prod,
    { simpa [fpprod, list.map_map, function.comp] using hw },
    simp only [monoid_hom.map_mul],
    erw [fprod, map_prod_of_eq_self, exp_sum_eq_one_of_mem_closure_var h₁ (not_not.2 rfl),
      mul_one],
    by_cases hw1 : w = 1,
    { subst hw1,
      use [fprod l],
      rcases prod_mem_partial_prod (l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)) with hl | hl,
      { simp [*, fpprod, list.partial_prod] at * },
      { use hl,
        simp } },
    { rw [mem_partial_prod_reverse_inv hw1, list.mem_map] at hw',
      rcases hw' with ⟨w, hw', rfl⟩ | rfl,
      { refine ⟨w, hw', _⟩,
        simp [exp_sum_eq_one_of_mem_closure_var h₁ (not_not.2 rfl)] },
      { exfalso,
        dsimp at hv1,
        erw [fprod, map_prod_of_eq_self] at hv1,
        simp [exp_sum_eq_one_of_mem_closure_var h₁ (not_not.2 rfl)] at hv1,
        tauto } } },
  { rw mem_map at hv,
    rcases hv with ⟨w, hw, rfl⟩,
    rw [monoid_hom.map_mul, exp_sum_eq_one_of_mem_closure_var
      (partial_prod_mem_blah hw h₁) (not_not.2 rfl), one_mul] at hv1 ⊢,
    use fprod l,
    rcases prod_mem_partial_prod (l.map (λ i : Σ i : ι, C∞, of' i.1 i.2)) with hl | hl,
    { simp [*, fpprod, list.partial_prod, fprod] at * },
    { use hl } },
  { use [v, hv, rfl] }
end

@[simp] lemma list.map_id'' {α : Type*} (l : list α) :
  l.map (λ x, x) = l := list.map_id l

lemma append_inv_reverse_exp_sum_eq_one {n : C∞} {t : ι} {l : list (Σ i : ι, C∞)} {r : free_group ι}
  (h₁ : r ∈ closure_var {i | i ≠ t})
  (h₂ : ∀ v, v ∈ fpprod l → n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1) :
  ∀ v ∈ fpprod ((l.map (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse ++ r.to_list ++ l),
    n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1 :=
begin
  assume v hv hn,
  by_contra hv1,
  rcases exp_sum_append_subset h₁ v hv hv1 with ⟨w, hw, hwv⟩,
  exact hv1 (hwv.symm ▸ h₂ w hw (hwv ▸ hn))
end

lemma append_conj_append_exp_sum_eq_one {n : C∞} {t : ι} {l₁ l₂ : list (Σ i : ι, C∞)} {r : free_group ι}
  (h₁ : r ∈ closure_var {i | i ≠ t})
  (h₂ : ∀ v, v ∈ fpprod l₁ → n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1)
  (h₃ : exp_sum t (fprod l₂) = 1)
  (h₄ : ∀ v, v ∈ fpprod l₂ → n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1) :
  ∀ v ∈ fpprod ((l₁.map (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
      ++ r.to_list ++ l₁ ++ l₂),
    n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1 :=
begin
  assume v hv hn,
  rw [fpprod, map_append, partial_prod_append, mem_append] at hv,
  cases hv with hv hv,
  { rw [mem_map] at hv,
    rcases hv with ⟨w, hw, rfl⟩,
    erw [monoid_hom.map_mul, h₃, mul_one] at hn ⊢,
    exact append_inv_reverse_exp_sum_eq_one h₁ h₂ _ hw hn },
  { exact h₄ _ hv hn }
end

lemma exp_sum_bind_conj {t : ι} {r : free_group ι} (L : list (list (Σ i : ι, C∞) × C∞))
  (h₁ : r ∈ closure_var {i | i ≠ t}) :
  exp_sum t (fprod (L.bind (λ l, (l.1.map (λ i : Σ i : ι, C∞,
    (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
      ++ (r ^ to_add l.2).to_list ++ l.1))) = 1 :=
begin
  induction L with l L ih,
  { simp [fprod] },
  { rw [cons_bind, fprod, map_append, prod_append, ← fprod, ← fprod,
      monoid_hom.map_mul, ih, mul_one],
    simp [fprod, function.comp],
    erw [map_prod_of_eq_self (r ^ to_add l.2),
      exp_sum_eq_one_of_mem_closure_var (subgroup.gpow_mem _ h₁ _) (not_not.2 rfl),
      one_mul],
    induction l.1 with i l ih,
    { simp },
    { simp; split_ifs; simp [mul_assoc, ih] } }
end

lemma bind_conj_exp_sum_eq_one {t : ι} (n : C∞) {r : free_group ι}
  (L : list (list (Σ i : ι, C∞) × C∞))
  (h₁ : r ∈ closure_var {i | i ≠ t})
  (h₂ : ∀ l : list (Σ i : ι, C∞) × C∞, l ∈ L →
    ∀ v, v ∈ fpprod l.1 → n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1) :
    ∀ v ∈ fpprod (L.bind (λ l,
      (l.1.map (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
      ++ (r ^ to_add l.2).to_list ++ l.1)),
     n.to_add ∣ (exp_sum t v).to_add → exp_sum t v = 1 :=
begin
  assume v hv hn,
  induction L with l L ih generalizing v,
  { simp [fpprod, *, list.partial_prod] at * },
  { rw [cons_bind] at hv,
    rcases prod_mem_partial_prod ((L.bind (λ l, (l.1.map
      (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
      ++ (r ^ to_add l.2).to_list ++ l.1)).map (λ i : Σ i : ι, C∞, of' i.1 i.2)) with hL | hL,
    { rw [fpprod, map_append, hL, append_nil] at hv,
      exact append_inv_reverse_exp_sum_eq_one (subgroup.gpow_mem _ h₁ _)
        (h₂ _ (mem_cons_self _ _)) _ hv hn },
    { exact append_conj_append_exp_sum_eq_one (subgroup.gpow_mem _ h₁ _)
        (h₂ l (mem_cons_self _ _)) (exp_sum_bind_conj _ h₁)
        (ih (λ l hl, h₂ l (mem_cons_of_mem _ hl))) _ hv hn } }
end

lemma map_reverse_eq_inv {l : list (Σ i : ι, C∞)} :
  (map (λ (i : Σ i : ι, C∞), (of' i.fst) i.snd)
    (map (λ (i : Σ i : ι, C∞), (⟨i.fst, (i.snd)⁻¹⟩ : Σ i : ι, C∞)) l).reverse).prod =
  (fprod l)⁻¹:=
begin
  induction l with i l ih,
  { simp [fprod] },
  { rw [map_cons, reverse_cons, map_append, prod_append, ih],
    simp [mul_assoc, fprod] }
end

-- lemma bind_conj_eq_lift {r : free_group ι} (p : free_group (free_group ι)) :
--   fprod ((p.to_list.map (λ l : Σ i : free_group ι, C∞, (l.1.to_list, l.2))).bind
--     (λ l, (l.1.map (λ i : Σ i : ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
--       ++ (r ^ to_add l.2).to_list ++ l.1)) = lift (λ g, g⁻¹ * r * g) p :=
-- begin
--   cases p with L hL,
--   induction L with l L ih,
--   { simp [fprod] },
--   { erw [map_cons, cons_bind, fprod, map_append, prod_append, ← fprod,
--       ← fprod, ih (coprod.pre.reduced_of_reduced_cons hL),
--       cons_eq_of'_mul, monoid_hom.map_mul, mul_right_cancel_iff,
--       free_group.lift, lift'_of', fprod, map_append, map_append,
--       prod_append, prod_append, map_prod_of_eq_self, map_prod_of_eq_self,
--       map_reverse_eq_inv l.1.2, ← mul_aut.conj_symm_apply _ (r ^ _),
--       ← mul_equiv.to_monoid_hom_apply, monoid_hom.map_gpow],
--     simp [gpowers_hom] }
-- end

lemma dvd_exp_sum_of_mem_blah {t : ι} {n : C∞} {w : free_group ι}
  (h : w ∈ blah (λ i : ι, ⨅ (h : t = i), subgroup.gpowers n)) :
  n.to_add ∣ (exp_sum t w).to_add :=
begin
  rw [← range_pow_single] at h,
  rcases h with ⟨v, rfl⟩,
  rw [← monoid_hom.comp_apply, exp_sum_comp_pow_single],
  simp [gpowers_hom]
end

def of_option (t : ι) (n : C∞) : free_group (option ι) →* free_group ι :=
free_group.lift (λ i : option ι, i.elim (of' t n) of)

lemma of_option_of' (t : ι) (i : option ι) (n m : C∞) : of_option t n (of' i m) =
  i.elim (of' t n ^ to_add m) (λ i, of' i m) :=
by simp [of_option, of'_eq_of_pow, monoid_hom.map_gpow]; cases i;
  simp [monoid_hom.map_gpow, gpow_add]

--true
-- lemma mem_thing {t : ι} {n : C∞}
--   {r : free_group (option ι)}
--   {p : free_group (free_group ι)}
--   (h : of_option t n (fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
--     ((eliminate_t t n w.1.to_list).1, w.2))).bind
--       (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
--         ++ (r ^ to_add l.2).to_list ++ l.1))) ∈ (pow_single t n).range) :
--   fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
--     ((eliminate_t t n w.1.to_list).1, w.2))).bind
--       (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
--         ++ (r ^ to_add l.2).to_list ++ l.1)) ∈ (pow_single (some t) n).range :=
-- begin
--   cases p with L hL,
--   induction L with w L ih,
--   { simp [fprod, subgroup.one_mem] },
--   { erw [cons_bind, fprod, map_append, prod_append, ← fprod, ← fprod],
--     refine subgroup.mul_mem _ _ _, }

-- end

-- lemma of_option_eliminate_t_conj_prod_mem_closure_var {t : ι} {n : C∞}
--   {r : free_group (option ι)}
--   {p : free_group (free_group ι)}
--   (hr : r ∈ closure_var {i | i ≠ some t})
--   (hp : of_option t n (fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
--     ((eliminate_t t n w.1.to_list).1, w.2))).bind
--       (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
--         ++ (r ^ to_add l.2).to_list ++ l.1))) ∈ (pow_single t n).range) :
--   of_fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
--     ((eliminate_t t n w.1.to_list).1, w.2))).bind
--       (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
--         ++ (r ^ to_add l.2).to_list ++ l.1)) ∈ closure_var {i | some t ≠ i} :=
-- begin
--   apply mem_closure_var_of_forall_exp_sum_eq_one,
--   assume v hv,
--   have hv' := (partial_prod_sublist _).subset hv,
--   refine bind_conj_exp_sum_eq_one n _ hr _ _ hv' _,
--   { assume l hl v hv hn,
--     rw [mem_map] at hl,
--     rcases hl with ⟨w, hw, rfl⟩,
--     exact eliminate_t_exp_sum_eq_one _ _ _ _ hv hn },
--   { refine dvd_exp_sum_of_mem_blah (partial_prod_mem_blah hv _),
--     rw [← range_pow_single],
--     exact hp }
-- end

lemma prod_bind_conj_eq_lift {t : ι} {n : C∞} (r : free_group (option ι))
  (p : free_group (free_group ι))  :
    (fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
      ((eliminate_t t n w.1.to_list).1, w.2))).bind
        (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
          ++ (r ^ to_add l.2).to_list ++ l.1))) =
  free_group.lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
    mul_aut.conj w⁻¹ r) p :=
begin
  cases p with L hL,
  induction L with w L ih,
  { simp [fprod] },
  { erw [fprod, map_cons, cons_bind, map_append, prod_append, ← fprod, ← fprod,
      ih (coprod.pre.reduced_of_reduced_cons hL)],
    conv_rhs { rw [cons_eq_of'_mul, monoid_hom.map_mul] },
    erw [mul_right_cancel_iff, of'_eq_of_pow, monoid_hom.map_gpow, lift_of,
      fprod, map_append, map_append, prod_append, prod_append,
      map_prod_of_eq_self (r ^ _), map_reverse_eq_inv],
    dsimp only,
    rw [← mul_equiv.to_monoid_hom_apply, ← monoid_hom.map_gpow],
    simp [mul_aut.inv_def, mul_aut.conj_symm_apply] }
end

--IMPORTANT
lemma eliminate_t_conj_prod_mem_closure_var {t : ι} {n : C∞}
  {r : free_group (option ι)}
  {p : free_group (free_group ι)}
  (hr : r ∈ closure_var {i | i ≠ some t})
  (hp : fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
    ((eliminate_t t n w.1.to_list).1, w.2))).bind
      (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
        ++ (r ^ to_add l.2).to_list ++ l.1)) ∈ (pow_single (some t) n).range) :
  fprod ((p.to_list.map (λ w : Σ i : free_group ι, C∞,
    ((eliminate_t t n w.1.to_list).1, w.2))).bind
      (λ l, (l.1.map (λ i : Σ i : option ι, C∞, (⟨i.1, i.2⁻¹⟩ : Σ i, C∞))).reverse
        ++ (r ^ to_add l.2).to_list ++ l.1)) ∈ closure_var {i | some t ≠ i} :=
begin
  apply mem_closure_var_of_forall_exp_sum_eq_one,
  assume v hv,
  have hv' := (partial_prod_sublist _).subset hv,
  refine bind_conj_exp_sum_eq_one n _ hr _ _ hv' _,
  { assume l hl v hv hn,
    rw [mem_map] at hl,
    rcases hl with ⟨w, hw, rfl⟩,
    exact eliminate_t_exp_sum_eq_one _ _ _ _ hv hn },
  { refine dvd_exp_sum_of_mem_blah (partial_prod_mem_blah hv _),
    rw [prod_bind_conj_eq_lift] at ⊢ hp,
    rw [← range_pow_single],
    exact hp }
end

lemma pow_single_map {t : ι} {n : C∞} (w : free_group ι):
  (pow_single (some t) n) (map some w) = map some ((pow_single t n) w) :=
begin
  simp only [← monoid_hom.comp_apply],
  refine congr_fun (congr_arg _ (hom_ext $ λ i, _)) _,
  simp [pow_single],
  split_ifs;
  simp [of'_eq_of_pow, monoid_hom.map_gpow]
end

lemma map_mem_range {t : ι} {n : C∞} {r : free_group ι}
  (hr : r ∈ (pow_single t n).range) :
  free_group.map some r ∈ (pow_single (some t) n).range :=
begin
  rcases monoid_hom.mem_range.1 hr with ⟨w, rfl⟩,
  rw [← pow_single_map],
  exact ⟨_, rfl⟩
end

lemma eliminate_t_conj_lift_mem_closure_var {t : ι} {n : C∞}
  {r : free_group (option ι)}
  {p : free_group (free_group ι)}
  (hr : r ∈ closure_var {i | i ≠ some t}) :
  lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
    mul_aut.conj w⁻¹ r) p ∈ (pow_single (some t) n).range →
 lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
    mul_aut.conj w⁻¹ r) p ∈ closure_var {i | some t ≠ i} :=
begin
  convert eliminate_t_conj_prod_mem_closure_var hr,
  rw prod_bind_conj_eq_lift
end

lemma lift_eliminate_t_conj_eq_lift (t : ι) {n : C∞} (hn : n ≠ 1)
  {r : free_group (option ι)} :
  free_group.lift (λ w, mul_aut.conj w⁻¹ (of_option t n r)) =
  (of_option t n).comp
    (lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
      mul_aut.conj w⁻¹ r)) :=
hom_ext begin
  assume w,
  simp only [mul_aut.inv_def, mul_aut.conj_symm_apply, monoid_hom.map_mul,
    monoid_hom.map_inv, monoid_hom.comp_apply, lift_of, of_option],
  erw [prod_eliminate_t _ _ _ hn, fprod, map_prod_of_eq_self]
end

lemma lift_eliminate_t_mem_range {t : ι} {n : C∞} (hn : n ≠ 1)
  {r : free_group (option ι)} (hr : of_option t n r ∈ (pow_single t n).range)
  {p : free_group (free_group ι)}
  (h : free_group.lift (λ w, mul_aut.conj w⁻¹ (of_option t n r)) p ∈ (pow_single t n).range) :
  lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
    mul_aut.conj w⁻¹ r) p ∈ (pow_single (some t) n).range := sorry

lemma lift_ite_eq_self_of_mem_closure_var {t : ι} {w : free_group ι}
  (hw : w ∈ closure_var {i | t ≠ i}) : free_group.lift (λ i, if i = t then 1 else of i) w = w :=
begin
  cases w with l hl,
  induction l with i l ih,
  { simp },
  { rw [cons_eq_of'_mul, monoid_hom.map_mul, ih
      (coprod.pre.reduced_of_reduced_cons hl) (λ i hi, hw i (mem_cons_of_mem _ hi)),
      of'_eq_of_pow, monoid_hom.map_gpow, lift_of],
    split_ifs,
    { have := hw i (mem_cons_self _ _),
      simp [h] at this,
      simp [this] },
    { refl } }
end

lemma lift_eliminate_t_eq_self_of_mem_pow_range {t : ι} {n : C∞} (hn : n ≠ 1)
  {r : free_group (option ι)} {p : free_group (free_group ι)}
  (hp : free_group.lift (λ w, mul_aut.conj w⁻¹ (of_option t n r)) p ∈ (pow_single t n).range)
  (hr : r ∈ closure_var {i : option ι | i ≠ some t}) :
  free_group.lift (λ i : option ι, i.elim (of' t n) (λ i, if i = t then 1 else of i))
    (free_group.lift (λ w, mul_aut.conj w⁻¹ r)
      (free_group.map (λ w : free_group ι, (fprod (eliminate_t t n w.to_list).1)) p)) =
  free_group.lift (λ w, mul_aut.conj w⁻¹ (of_option t n r)) p :=
calc free_group.lift (λ i : option ι, i.elim (of' t n) (λ i, if i = t then 1 else of i))
    (free_group.lift (λ w, mul_aut.conj w⁻¹ r)
      (free_group.map (λ w : free_group ι, (fprod (eliminate_t t n w.to_list).1)) p)) =
    of_option t n
     (free_group.lift (λ i : option ι, if i = some t then 1 else of i)
    ((free_group.lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
      mul_aut.conj w⁻¹ r)) p)) :
  begin
    simp only [← monoid_hom.comp_apply],
    refine congr_fun (congr_arg _ _) _,
    refine hom_ext _,
    assume i,
    simp only [← monoid_hom.comp_apply],
    have : free_group.lift (λ i : option ι, i.elim (of' t n)
        (λ (i : ι), ite (i = t) 1 (of i))) =
        (of_option t n).comp
          (free_group.lift (λ i : option ι, ite (i = some t) 1 (of i))),
      from hom_ext (λ i, option.cases_on i (by simp [of_option, of'_eq_of_pow])
        (λ i, by simp; split_ifs; simp [*, of_option])),
    refine congr_fun (congr_arg _ _) _,
    refine hom_ext _,
    assume i,
    simp [this, monoid_hom.comp_apply, of_option],
  end
... = of_option t n
    ((free_group.lift (λ w : free_group ι, let w := fprod (eliminate_t t n w.to_list).1 in
      mul_aut.conj w⁻¹ r)) p) :
  begin
    unfold of_option,
    refine congr_arg _ _,
    refine lift_ite_eq_self_of_mem_closure_var _,
    refine eliminate_t_conj_lift_mem_closure_var hr _,
    refine lift_eliminate_t_mem_range hn sorry hp,
  end
... = _ : by rw [← monoid_hom.comp_apply, lift_eliminate_t_conj_eq_lift _ hn]
-- lemma prod_mem_of_eliminate_t_mem (t : ι) (n : C∞)
--   (l : list (Σ i : ι, C∞)) (hn : n ≠ 1)
--   (h : ((eliminate_t t n l).1.map (λ i : Σ i : option ι, C∞, of' i.1 i.2)).prod ∈
--     (pow_single (some t) n).range) :
--   ((eliminate_t t n l).1.map (λ i : Σ i : option ι, C∞, of' i.1 i.2)).prod ∈
--     closure_var {i | some t ≠ i} :=
-- mem_closure_var_of_forall_exp_sum_eq_one $ λ w hw,
--   eliminate_t_exp_sum_eq_one _ _ _ _
--     ((partial_prod_sublist _).subset hw)
--     (dvd_exp_sum_of_mem_blah
--       ((mem_blah_iff_partial_prod_mem_blah _ _).2 (by rwa [← range_pow_single]) w hw))

-- def pow_proof_aux (t : ι) (n s : C∞) : Π (l : list (Σ i : ι, C∞)), free_group ι × C∞
-- | []     := (1, s)
-- | (i::l) := let w := pow_proof_aux l in
-- if t = i.1
--   then if n.to_add ∣ to_add i.2 + to_add w.2
--     then (of' t (of_add ((to_add i.2 + to_add w.2) / n.to_add)) * w.1, 1)
--     else (w.1, i.2 * w.2)
--   else (of' i.1 i.2 * w.1, w.2)

-- lemma pow_proof_append (t : ι) (n : C∞) (s : C∞) : Π (l₁ l₂ : list (Σ i : ι, C∞)),
--   pow_proof t n s (l₁ ++ l₂) = ((pow_proof t n (pow_proof t n s l₂).2 l₁).1 * (pow_proof t n s l₂).1,
--     (pow_proof t n (pow_proof t n s l₂).2 l₁).2)
-- | []      l₂ := by simp [pow_proof]
-- | (i::l₁) l₂ := begin
--   rw [cons_append, pow_proof, pow_proof_append],
--   simp [pow_proof],
--   split_ifs; simp [mul_assoc]
-- end

/-- tail recursive pow_proof -/
def pow_proof_core (t : ι) (n : C∞) : Π (l : list (Σ i : ι, C∞)), free_group ι × C∞ → free_group ι × C∞
| []     w := w
| (i::l) w :=
if t = i.1
  then if n.to_add ∣ to_add i.2 + to_add w.2
    then pow_proof_core l (w.1 * of' t (of_add ((to_add i.2 + to_add w.2) / n.to_add)), 1)
    else pow_proof_core l (w.1, i.2 * w.2)
  else pow_proof_core l (w.1 * of' i.1 i.2, w.2)

def pow_proof (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) : free_group ι :=
(pow_proof_core t n l 1).1

#eval (pow_proof 0 (of_add 2) [⟨2, of_add 1⟩, ⟨1, of_add 1⟩, ⟨3, of_add 1⟩]).1

#eval (pow_proof 0 (of_add 2) [⟨1, of_add 2⟩, ⟨3, of_add 2⟩]).1

lemma pow_proof_core_append (t : ι) (n : C∞) : Π (l₁ l₂ : list (Σ i : ι, C∞)) (w : free_group ι × C∞) ,
  pow_proof_core t n (l₁ ++ l₂) w = pow_proof_core t n l₂ (pow_proof_core t n l₁ w)
| []      l₂ w := rfl
| (i::l₁) l₂ w :=
begin
  rw [cons_append, pow_proof_core, pow_proof_core_append, pow_proof_core],
  split_ifs; simp [pow_proof_core_append, pow_proof_core],
end

def eliminate_t' (t : ι) (n s : C∞) : list (Σ i : ι, C∞) → list (Σ i : option ι, C∞) × C∞
| []     := ([], s)
| (i::l) :=
let x := eliminate_t' l in
if t = i.1
  then if n.to_add ∣ to_add i.2 + to_add x.2
    then (⟨none, of_add ((to_add i.2 + to_add x.2) / n.to_add)⟩ ::
      ⟨some i.1, x.2⁻¹⟩ :: x.1, 1)
    else (⟨some i.1, i.2⟩ :: x.1, i.2 * x.2)
  else (⟨some i.1, i.2⟩ :: x.1, x.2)

@[simp] lemma eliminate_t'_one (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
  eliminate_t' t n 1 l = eliminate_t t n l :=
by induction l; simp [*, eliminate_t, eliminate_t']

lemma pow_proof_core_snd (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) (w : free_group ι × C∞) :
  (pow_proof_core t n l.reverse w).2 = (eliminate_t' t n w.2 l).2 :=
begin
  induction l with i l ih,
  { simp [pow_proof_core, eliminate_t'] },
  { simp [pow_proof_core, eliminate_t', pow_proof_core_append, ih],
    split_ifs; refl }
end

lemma pow_proof_core_eq_eliminate_t' (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) (w : free_group ι × C∞) :
  (pow_proof_core t n l.reverse w).1 = w.1 * free_group.lift
    (λ i : option ι, i.elim (of t) (λ i, if i = t then 1 else of i))
    (fprod (eliminate_t' t n w.2 l).1.reverse):=
begin
  induction l with i l ih generalizing w,
  { simp [pow_proof_core, eliminate_t', fprod] },
  { simp [pow_proof_core_append, pow_proof_core, eliminate_t', pow_proof_core_snd],
    split_ifs,
    { simp [ih, fprod, mul_assoc, ← h, gpowers_hom, of'_eq_of_pow, monoid_hom.map_gpow] },
    { simp [ih, fprod, mul_assoc, ← h, gpowers_hom, of'_eq_of_pow, monoid_hom.map_gpow] },
    { simp [ih, fprod, mul_assoc, gpowers_hom, of'_eq_of_pow, monoid_hom.map_gpow, ne.symm h] } }
end

lemma pow_proof_eq_eliminate_t (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
  pow_proof t n l.reverse = free_group.lift
    (λ i : option ι, i.elim (of t) (λ i, if i = t then 1 else of i))
    (fprod (eliminate_t t n l).1.reverse) :=
by simp [pow_proof, pow_proof_core_eq_eliminate_t']

def pow_single_inverse_aux (t : ι) (n : C∞) : list (Σ i : ι, C∞) → option (list Σ i : ι, C∞)
| []    := some []
| (i::l)  :=
do l' ← pow_single_inverse_aux l,
if i.1 = t
  then if to_add n ∣ i.2
    then return (⟨i.1, of_add $ to_add i.2 / to_add n⟩ :: l')
    else none
  else i :: l'

lemma pow_single_inverse_aux_reduced (t : ι) (n : C∞) :
  ∀ l : list (Σ i : ι, C∞), coprod.pre.reduced l →
    ∀ l' ∈ pow_single_inverse_aux t n l, coprod.pre.reduced l' := sorry

def pow_single_inverse (t : ι) (n : C∞) (w : free_group ι) : option (free_group ι) :=
begin
  cases h : pow_single_inverse_aux t n w.1,
  { exact none },
  { exact some ⟨val, pow_single_inverse_aux_reduced t n w.1 w.2 _ h⟩ }
end

def pow_single_pullback (t : ι) (n : C∞) (p : P (free_group ι)) : option (P (free_group ι)) :=
(pow_single_inverse t n p.2).map (λ w, ⟨map (λ w : free_group ι, pow_proof t n w.to_list) p.1, w⟩)

#eval (pow_single_pullback 0 (of_add 3) ⟨of (of 0 ^(-6 : ℤ) * of 2 * of 1) * of (of 1)⁻¹, 1⟩).iget.left

-- lemma pow_proof_core_eq' (t : ι) (n : C∞) : ∀ (l₁ l₂ : list (Σ i : ι, C∞)) (s : C∞),
--   pow_proof_core t n l₂.reverse (pow_proof_aux t n s l₁) =
--     pow_proof_aux t n s (l₁ ++ l₂)
-- | []        [] s := rfl
-- | []  (i ::l₂) s := begin
--   simp [pow_proof_aux,],

-- end
-- | []        l₂ s := by simp [pow_proof_core, pow_proof_aux]
-- | (i::l₁)   l₂ s := begin
--   simp only [reverse_cons, pow_proof_core_append, pow_proof_core, pow_proof_core,
--     cons_append, pow_proof_aux],
--   simp only [pow_proof_core_eq'],
--   split_ifs, simp [mul_assoc, pow_proof_aux],
-- end

-- lemma pow_proof_core_eq (t : ι) (n : C∞) : ∀ (l : list (Σ i : ι, C∞)) (w : free_group ι × C∞),
--   pow_proof_core t n l.reverse w = (w.1 * (pow_proof_aux t n w.2 l).1 * w.1, (pow_proof_aux t n w.2 l).2)
-- | []     w := by simp [pow_proof_core, pow_proof_aux]
-- | (i::l) w := begin
--   simp only [reverse_cons, pow_proof_core_append, pow_proof_core, pow_proof_core, pow_proof_aux],
--   simp only [pow_proof_core_eq],
--   split_ifs; simp [mul_assoc]
-- end

-- lemma pow_proof_eq (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
--   pow_proof t n l = (pow_proof_aux t n 1 l.reverse).1 :=
-- begin
--   rw [← reverse_reverse l, pow_proof, pow_proof_core_eq],
--   simp,
-- end

-- lemma pow_proof_aux_snd (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
--   (pow_proof_aux t n 1 l).2 = (eliminate_t t n l).2 :=
-- begin
--   induction l with i l ih,
--   { refl },
--   { simp [pow_proof_aux, eliminate_t],
--     split_ifs; simp * at * }
-- end

-- lemma pow_proof_aux_eq_eliminate_t (t : ι) (n : C∞) : ∀ (l : list (Σ i : ι, C∞)),
--   (pow_proof_aux t n 1 l).1 = free_group.lift
--     (λ i : option ι, i.elim (of t) (λ i, if i = t then 1 else of i))
--     (fprod (eliminate_t t n l).1)
-- | []     := by simp [pow_proof_aux, eliminate_t, fprod]
-- | (i::l) := begin
--   simp only [pow_proof_aux, fprod, eliminate_t, pow_proof_aux_eq_eliminate_t l, pow_proof_aux_snd],
--   split_ifs;
--   simp [*, monoid_hom.map_list_prod, of_eq_of', free_group.lift, gpowers_hom, @eq_comm _ _ t];
--   simp [of'_eq_of_pow]
-- end

-- lemma pow_proof_eq_eliminate_t (t : ι) (n : C∞) (l : list (Σ i : ι, C∞)) :
--   pow_proof t n l = free_group.lift
--     (λ i : option ι, i.elim (of t) (λ i, if i = t then 1 else of i))
--     (fprod (eliminate_t t n l.reverse).1) :=
-- by rw [pow_proof_eq, pow_proof_aux_eq_eliminate_t]

-- -- lemma pow_proof_snd_append_of_pow_proof_snd_eq_one
-- --   {t : ι} {n : C∞} {l₁ l₂ : list (Σ i : ι, C∞)}
-- --   (hl : (pow_proof t n l₂).2 = 1) :
-- --   (pow_proof t n (l₁ ++ l₂)).2 = (pow_proof t n l₁).2  :=
-- -- begin
-- --   induction l₁ with i l₁ ih,
-- --   { simp [pow_proof, hl] },
-- --   { simp [list.cons_append, pow_proof, ih],
-- --     split_ifs; refl }
-- -- end

-- -- lemma pow_proof_append_of_pow_proof_snd_eq_one {t : ι} {n : C∞} {l₁ l₂ : list (Σ i : ι, C∞)}
-- --   (hl : (pow_proof t n l₂).2 = 1) :
-- --   (pow_proof t n (l₁ ++ l₂)).1 = (pow_proof t n l₁).1 * (pow_proof t n l₂).1 :=
-- -- begin
-- --   induction l₁ with i l₁ ih,
-- --   { simp [pow_proof], },
-- --   { rw [list.cons_append, pow_proof],
-- --     dsimp,
-- --     rw ih,
-- --     simp [pow_proof, pow_proof_snd_append_of_pow_proof_snd_eq_one hl],
-- --     split_ifs,
-- --     { simp [mul_assoc, ih, hl] },
-- --     { refl },
-- --     { rw [mul_assoc] } }
-- -- end


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

! This file was ported from Lean 3 source module ring_theory.is_tensor_product
! leanprover-community/mathlib commit c4926d76bb9c5a4a62ed2f03d998081786132105
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.TensorProduct
import Mathbin.Algebra.Module.Ulift

/-!
# The characteristice predicate of tensor product

## Main definitions

- `is_tensor_product`: A predicate on `f : M₁ →ₗ[R] M₂ →ₗ[R] M` expressing that `f` realizes `M` as
  the tensor product of `M₁ ⊗[R] M₂`. This is defined by requiring the lift `M₁ ⊗[R] M₂ → M` to be
  bijective.
- `is_base_change`: A predicate on an `R`-algebra `S` and a map `f : M →ₗ[R] N` with `N` being a
  `S`-module, expressing that `f` realizes `N` as the base change of `M` along `R → S`.
- `algebra.is_pushout`: A predicate on the following diagram of scalar towers
  ```
    R  →  S
    ↓     ↓
    R' →  S'
  ```
    asserting that is a pushout diagram (i.e. `S' = S ⊗[R] R'`)

## Main results
- `tensor_product.is_base_change`: `S ⊗[R] M` is the base change of `M` along `R → S`.

-/

universe u v₁ v₂ v₃ v₄

open TensorProduct

open TensorProduct

section IsTensorProduct

variable {R : Type _} [CommRing R]

variable {M₁ M₂ M M' : Type _}

variable [AddCommMonoid M₁] [AddCommMonoid M₂] [AddCommMonoid M] [AddCommMonoid M']

variable [Module R M₁] [Module R M₂] [Module R M] [Module R M']

variable (f : M₁ →ₗ[R] M₂ →ₗ[R] M)

variable {N₁ N₂ N : Type _} [AddCommMonoid N₁] [AddCommMonoid N₂] [AddCommMonoid N]

variable [Module R N₁] [Module R N₂] [Module R N]

variable {g : N₁ →ₗ[R] N₂ →ₗ[R] N}

/-- Given a bilinear map `f : M₁ →ₗ[R] M₂ →ₗ[R] M`, `is_tensor_product f` means that
`M` is the tensor product of `M₁` and `M₂` via `f`.
This is defined by requiring the lift `M₁ ⊗[R] M₂ → M` to be bijective.
-/
def IsTensorProduct : Prop :=
  Function.Bijective (TensorProduct.lift f)
#align is_tensor_product IsTensorProduct

variable (R M N) {f}

theorem TensorProduct.isTensorProduct : IsTensorProduct (TensorProduct.mk R M N) :=
  by
  delta IsTensorProduct
  convert_to Function.Bijective LinearMap.id using 2
  · apply TensorProduct.ext'
    simp
  · exact Function.bijective_id
#align tensor_product.is_tensor_product TensorProduct.isTensorProduct

variable {R M N}

/-- If `M` is the tensor product of `M₁` and `M₂`, it is linearly equivalent to `M₁ ⊗[R] M₂`. -/
@[simps apply]
noncomputable def IsTensorProduct.equiv (h : IsTensorProduct f) : M₁ ⊗[R] M₂ ≃ₗ[R] M :=
  LinearEquiv.ofBijective _ h
#align is_tensor_product.equiv IsTensorProduct.equiv

@[simp]
theorem IsTensorProduct.equiv_toLinearMap (h : IsTensorProduct f) :
    h.Equiv.toLinearMap = TensorProduct.lift f :=
  rfl
#align is_tensor_product.equiv_to_linear_map IsTensorProduct.equiv_toLinearMap

@[simp]
theorem IsTensorProduct.equiv_symm_apply (h : IsTensorProduct f) (x₁ : M₁) (x₂ : M₂) :
    h.Equiv.symm (f x₁ x₂) = x₁ ⊗ₜ x₂ :=
  by
  apply h.equiv.injective
  refine' (h.equiv.apply_symm_apply _).trans _
  simp
#align is_tensor_product.equiv_symm_apply IsTensorProduct.equiv_symm_apply

/-- If `M` is the tensor product of `M₁` and `M₂`, we may lift a bilinear map `M₁ →ₗ[R] M₂ →ₗ[R] M'`
to a `M →ₗ[R] M'`. -/
noncomputable def IsTensorProduct.lift (h : IsTensorProduct f) (f' : M₁ →ₗ[R] M₂ →ₗ[R] M') :
    M →ₗ[R] M' :=
  (TensorProduct.lift f').comp h.Equiv.symm.toLinearMap
#align is_tensor_product.lift IsTensorProduct.lift

theorem IsTensorProduct.lift_eq (h : IsTensorProduct f) (f' : M₁ →ₗ[R] M₂ →ₗ[R] M') (x₁ : M₁)
    (x₂ : M₂) : h.lift f' (f x₁ x₂) = f' x₁ x₂ :=
  by
  delta IsTensorProduct.lift
  simp
#align is_tensor_product.lift_eq IsTensorProduct.lift_eq

/-- The tensor product of a pair of linear maps between modules. -/
noncomputable def IsTensorProduct.map (hf : IsTensorProduct f) (hg : IsTensorProduct g)
    (i₁ : M₁ →ₗ[R] N₁) (i₂ : M₂ →ₗ[R] N₂) : M →ₗ[R] N :=
  hg.Equiv.toLinearMap.comp ((TensorProduct.map i₁ i₂).comp hf.Equiv.symm.toLinearMap)
#align is_tensor_product.map IsTensorProduct.map

theorem IsTensorProduct.map_eq (hf : IsTensorProduct f) (hg : IsTensorProduct g) (i₁ : M₁ →ₗ[R] N₁)
    (i₂ : M₂ →ₗ[R] N₂) (x₁ : M₁) (x₂ : M₂) : hf.map hg i₁ i₂ (f x₁ x₂) = g (i₁ x₁) (i₂ x₂) :=
  by
  delta IsTensorProduct.map
  simp
#align is_tensor_product.map_eq IsTensorProduct.map_eq

theorem IsTensorProduct.inductionOn (h : IsTensorProduct f) {C : M → Prop} (m : M) (h0 : C 0)
    (htmul : ∀ x y, C (f x y)) (hadd : ∀ x y, C x → C y → C (x + y)) : C m :=
  by
  rw [← h.equiv.right_inv m]
  generalize h.equiv.inv_fun m = y
  change C (TensorProduct.lift f y)
  induction y using TensorProduct.induction_on
  · rwa [map_zero]
  · rw [TensorProduct.lift.tmul]
    apply htmul
  · rw [map_add]
    apply hadd <;> assumption
#align is_tensor_product.induction_on IsTensorProduct.inductionOn

end IsTensorProduct

section IsBaseChange

variable {R : Type _} {M : Type v₁} {N : Type v₂} (S : Type v₃)

variable [AddCommMonoid M] [AddCommMonoid N] [CommRing R]

variable [CommRing S] [Algebra R S] [Module R M] [Module R N] [Module S N] [IsScalarTower R S N]

variable (f : M →ₗ[R] N)

include f

/-- Given an `R`-algebra `S` and an `R`-module `M`, an `S`-module `N` together with a map
`f : M →ₗ[R] N` is the base change of `M` to `S` if the map `S × M → N, (s, m) ↦ s • f m` is the
tensor product. -/
def IsBaseChange : Prop :=
  IsTensorProduct
    (((Algebra.ofId S <| Module.End S (M →ₗ[R] N)).toLinearMap.flip f).restrictScalars R)
#align is_base_change IsBaseChange

variable {S f} (h : IsBaseChange S f)

variable {P Q : Type _} [AddCommMonoid P] [Module R P]

variable [AddCommMonoid Q] [Module S Q]

section

variable [Module R Q] [IsScalarTower R S Q]

/-- Suppose `f : M →ₗ[R] N` is the base change of `M` along `R → S`. Then any `R`-linear map from
`M` to an `S`-module factors thorugh `f`. -/
noncomputable def IsBaseChange.lift (g : M →ₗ[R] Q) : N →ₗ[S] Q :=
  {
    h.lift
      (((Algebra.ofId S <| Module.End S (M →ₗ[R] Q)).toLinearMap.flip g).restrictScalars R) with
    map_smul' := fun r x =>
      by
      let F := ((Algebra.ofId S <| Module.End S (M →ₗ[R] Q)).toLinearMap.flip g).restrictScalars R
      have hF : ∀ (s : S) (m : M), h.lift F (s • f m) = s • g m := h.lift_eq F
      change h.lift F (r • x) = r • h.lift F x
      apply h.induction_on x
      · rw [smul_zero, map_zero, smul_zero]
      · intro s m
        change h.lift F (r • s • f m) = r • h.lift F (s • f m)
        rw [← mul_smul, hF, hF, mul_smul]
      · intro x₁ x₂ e₁ e₂
        rw [map_add, smul_add, map_add, smul_add, e₁, e₂] }
#align is_base_change.lift IsBaseChange.lift

theorem IsBaseChange.lift_eq (g : M →ₗ[R] Q) (x : M) : h.lift g (f x) = g x :=
  by
  have hF : ∀ (s : S) (m : M), h.lift g (s • f m) = s • g m := h.lift_eq _
  convert hF 1 x <;> rw [one_smul]
#align is_base_change.lift_eq IsBaseChange.lift_eq

theorem IsBaseChange.lift_comp (g : M →ₗ[R] Q) : ((h.lift g).restrictScalars R).comp f = g :=
  LinearMap.ext (h.liftEq g)
#align is_base_change.lift_comp IsBaseChange.lift_comp

end

include h

@[elab_as_elim]
theorem IsBaseChange.inductionOn (x : N) (P : N → Prop) (h₁ : P 0) (h₂ : ∀ m : M, P (f m))
    (h₃ : ∀ (s : S) (n), P n → P (s • n)) (h₄ : ∀ n₁ n₂, P n₁ → P n₂ → P (n₁ + n₂)) : P x :=
  h.inductionOn x h₁ (fun s y => h₃ _ _ (h₂ _)) h₄
#align is_base_change.induction_on IsBaseChange.inductionOn

theorem IsBaseChange.alg_hom_ext (g₁ g₂ : N →ₗ[S] Q) (e : ∀ x, g₁ (f x) = g₂ (f x)) : g₁ = g₂ :=
  by
  ext x
  apply h.induction_on x
  · rw [map_zero, map_zero]
  · assumption
  · intro s n e'
    rw [g₁.map_smul, g₂.map_smul, e']
  · intro x y e₁ e₂
    rw [map_add, map_add, e₁, e₂]
#align is_base_change.alg_hom_ext IsBaseChange.alg_hom_ext

theorem IsBaseChange.alg_hom_ext' [Module R Q] [IsScalarTower R S Q] (g₁ g₂ : N →ₗ[S] Q)
    (e : (g₁.restrictScalars R).comp f = (g₂.restrictScalars R).comp f) : g₁ = g₂ :=
  h.alg_hom_ext g₁ g₂ (LinearMap.congr_fun e)
#align is_base_change.alg_hom_ext' IsBaseChange.alg_hom_ext'

variable (R M N S)

omit h f

theorem TensorProduct.isBaseChange : IsBaseChange S (TensorProduct.mk R S M 1) :=
  by
  delta IsBaseChange
  convert TensorProduct.isTensorProduct R S M using 1
  ext (s x)
  change s • 1 ⊗ₜ x = s ⊗ₜ x
  rw [TensorProduct.smul_tmul']
  congr 1
  exact mul_one _
#align tensor_product.is_base_change TensorProduct.isBaseChange

variable {R M N S}

/-- The base change of `M` along `R → S` is linearly equivalent to `S ⊗[R] M`. -/
noncomputable def IsBaseChange.equiv : S ⊗[R] M ≃ₗ[S] N :=
  { h.Equiv with
    map_smul' := fun r x => by
      change h.equiv (r • x) = r • h.equiv x
      apply TensorProduct.induction_on x
      · rw [smul_zero, map_zero, smul_zero]
      · intro x y
        simp [smul_tmul', Algebra.ofId_apply]
      · intro x y hx hy
        rw [map_add, smul_add, map_add, smul_add, hx, hy] }
#align is_base_change.equiv IsBaseChange.equiv

theorem IsBaseChange.equiv_tmul (s : S) (m : M) : h.Equiv (s ⊗ₜ m) = s • f m :=
  TensorProduct.lift.tmul s m
#align is_base_change.equiv_tmul IsBaseChange.equiv_tmul

theorem IsBaseChange.equiv_symm_apply (m : M) : h.Equiv.symm (f m) = 1 ⊗ₜ m := by
  rw [h.equiv.symm_apply_eq, h.equiv_tmul, one_smul]
#align is_base_change.equiv_symm_apply IsBaseChange.equiv_symm_apply

variable (f)

theorem IsBaseChange.ofLiftUnique
    (h :
      ∀ (Q : Type max v₁ v₂ v₃) [AddCommMonoid Q],
        ∀ [Module R Q] [Module S Q],
          ∀ [IsScalarTower R S Q],
            ∀ g : M →ₗ[R] Q, ∃! g' : N →ₗ[S] Q, (g'.restrictScalars R).comp f = g) :
    IsBaseChange S f :=
  by
  obtain ⟨g, hg, -⟩ :=
    h (ULift.{v₂} <| S ⊗[R] M)
      (ulift.module_equiv.symm.to_linear_map.comp <| TensorProduct.mk R S M 1)
  let f' : S ⊗[R] M →ₗ[R] N := _
  change Function.Bijective f'
  let f'' : S ⊗[R] M →ₗ[S] N :=
    by
    refine'
      { f' with
        toFun := f'
        map_smul' := fun s x =>
          TensorProduct.induction_on x _ (fun s' y => smul_assoc s s' _) fun x y hx hy => _ }
    · rw [map_zero, smul_zero, map_zero, smul_zero]
    · rw [smul_add, map_add, map_add, smul_add, hx, hy]
  simp_rw [FunLike.ext_iff, LinearMap.comp_apply, LinearMap.restrictScalars_apply] at hg
  let fe : S ⊗[R] M ≃ₗ[S] N :=
    LinearEquiv.ofLinear f'' (ulift.module_equiv.to_linear_map.comp g) _ _
  · exact fe.bijective
  · rw [← LinearMap.cancel_left (ULift.moduleEquiv : ULift.{max v₁ v₃} N ≃ₗ[S] N).symm.Injective]
    refine' (h (ULift.{max v₁ v₃} N) <| ulift.module_equiv.symm.to_linear_map.comp f).unique _ rfl
    · infer_instance
    ext x
    simp only [LinearMap.comp_apply, LinearMap.restrictScalars_apply, hg]
    apply one_smul
  · ext x
    change (g <| (1 : S) • f x).down = _
    rw [one_smul, hg]
    rfl
#align is_base_change.of_lift_unique IsBaseChange.ofLiftUnique

variable {f}

theorem IsBaseChange.iff_lift_unique :
    IsBaseChange S f ↔
      ∀ (Q : Type max v₁ v₂ v₃) [AddCommMonoid Q],
        ∀ [Module R Q] [Module S Q],
          ∀ [IsScalarTower R S Q],
            ∀ g : M →ₗ[R] Q, ∃! g' : N →ₗ[S] Q, (g'.restrictScalars R).comp f = g :=
  ⟨fun h => by
    intros
    exact ⟨h.lift g, h.lift_comp g, fun g' e => h.alg_hom_ext' _ _ (e.trans (h.lift_comp g).symm)⟩,
    IsBaseChange.ofLiftUnique f⟩
#align is_base_change.iff_lift_unique IsBaseChange.iff_lift_unique

theorem IsBaseChange.ofEquiv (e : M ≃ₗ[R] N) : IsBaseChange R e.toLinearMap :=
  by
  apply IsBaseChange.ofLiftUnique
  intro Q I₁ I₂ I₃ I₄ g
  have : I₂ = I₃ := by
    ext (r q)
    rw [← one_smul R q, smul_smul, ← smul_assoc, smul_eq_mul, mul_one]
  cases this
  refine'
    ⟨g.comp e.symm.to_linear_map, by
      ext
      simp, _⟩
  rintro y (rfl : _ = _)
  ext
  simp
#align is_base_change.of_equiv IsBaseChange.ofEquiv

variable {T O : Type _} [CommRing T] [Algebra R T] [Algebra S T] [IsScalarTower R S T]

variable [AddCommMonoid O] [Module R O] [Module S O] [Module T O] [IsScalarTower S T O]

variable [IsScalarTower R S O] [IsScalarTower R T O]

theorem IsBaseChange.comp {f : M →ₗ[R] N} (hf : IsBaseChange S f) {g : N →ₗ[S] O}
    (hg : IsBaseChange T g) : IsBaseChange T ((g.restrictScalars R).comp f) :=
  by
  apply IsBaseChange.ofLiftUnique
  intro Q _ _ _ _ i
  letI := Module.compHom Q (algebraMap S T)
  haveI : IsScalarTower S T Q :=
    ⟨fun x y z => by
      rw [Algebra.smul_def, mul_smul]
      rfl⟩
  have : IsScalarTower R S Q := by
    refine' ⟨fun x y z => _⟩
    change (IsScalarTower.toAlgHom R S T) (x • y) • z = x • algebraMap S T y • z
    rw [AlgHom.map_smul, smul_assoc]
    rfl
  refine'
    ⟨hg.lift (hf.lift i), by
      ext
      simp [IsBaseChange.lift_eq], _⟩
  rintro g' (e : _ = _)
  refine' hg.alg_hom_ext' _ _ (hf.alg_hom_ext' _ _ _)
  rw [IsBaseChange.lift_comp, IsBaseChange.lift_comp, ← e]
  ext
  rfl
#align is_base_change.comp IsBaseChange.comp

variable {R' S' : Type _} [CommRing R'] [CommRing S']

variable [Algebra R R'] [Algebra S S'] [Algebra R' S'] [Algebra R S']

variable [IsScalarTower R R' S'] [IsScalarTower R S S']

open IsScalarTower (toAlgHom)

variable (R S R' S')

/-- A type-class stating that the following diagram of scalar towers
R  →  S
↓     ↓
R' →  S'
is a pushout diagram (i.e. `S' = S ⊗[R] R'`)
-/
@[mk_iff]
class Algebra.IsPushout : Prop where
  out : IsBaseChange S (toAlgHom R R' S').toLinearMap
#align algebra.is_pushout Algebra.IsPushout

variable {R S R' S'}

theorem Algebra.IsPushout.symm (h : Algebra.IsPushout R S R' S') : Algebra.IsPushout R R' S S' :=
  by
  letI := (Algebra.TensorProduct.includeRight : R' →ₐ[R] S ⊗ R').toRingHom.toAlgebra
  let e : R' ⊗[R] S ≃ₗ[R'] S' :=
    by
    refine' { (TensorProduct.comm R R' S).trans <| h.1.Equiv.restrictScalars R with map_smul' := _ }
    intro r x
    change
      h.1.Equiv (TensorProduct.comm R R' S (r • x)) = r • h.1.Equiv (TensorProduct.comm R R' S x)
    apply TensorProduct.induction_on x
    · simp only [smul_zero, map_zero]
    · intro x y
      simp [smul_tmul', Algebra.smul_def, RingHom.algebraMap_toAlgebra, h.1.equiv_tmul]
      ring
    · intro x y hx hy
      simp only [map_add, smul_add, hx, hy]
  have :
    (to_alg_hom R S S').toLinearMap =
      (e.to_linear_map.restrict_scalars R).comp (TensorProduct.mk R R' S 1) :=
    by
    ext
    simp [e, h.1.equiv_tmul, Algebra.smul_def]
  constructor
  rw [this]
  exact (TensorProduct.isBaseChange R S R').comp (IsBaseChange.ofEquiv e)
#align algebra.is_pushout.symm Algebra.IsPushout.symm

variable (R S R' S')

theorem Algebra.IsPushout.comm : Algebra.IsPushout R S R' S' ↔ Algebra.IsPushout R R' S S' :=
  ⟨Algebra.IsPushout.symm, Algebra.IsPushout.symm⟩
#align algebra.is_pushout.comm Algebra.IsPushout.comm

variable {R S R'}

attribute [local instance] Algebra.TensorProduct.rightAlgebra

instance TensorProduct.isPushout {R S T : Type _} [CommRing R] [CommRing S] [CommRing T]
    [Algebra R S] [Algebra R T] : Algebra.IsPushout R S T (TensorProduct R S T) :=
  ⟨TensorProduct.isBaseChange R T S⟩
#align tensor_product.is_pushout TensorProduct.isPushout

instance TensorProduct.isPushout' {R S T : Type _} [CommRing R] [CommRing S] [CommRing T]
    [Algebra R S] [Algebra R T] : Algebra.IsPushout R T S (TensorProduct R S T) :=
  Algebra.IsPushout.symm inferInstance
#align tensor_product.is_pushout' TensorProduct.isPushout'

/-- If `S' = S ⊗[R] R'`, then any pair of `R`-algebra homomorphisms `f : S → A` and `g : R' → A`
such that `f x` and `g y` commutes for all `x, y` descends to a (unique) homomoprhism `S' → A`.
-/
@[simps (config := lemmasOnly) apply]
noncomputable def Algebra.pushoutDesc [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (hf : ∀ x y, f x * g y = g y * f x) :
    S' →ₐ[R] A := by
  letI := Module.compHom A f.to_ring_hom
  haveI : IsScalarTower R S A :=
    {
      smul_assoc := fun r s a =>
        show f (r • s) * a = r • (f s * a) by rw [f.map_smul, smul_mul_assoc] }
  haveI : IsScalarTower S A A := { smul_assoc := fun r a b => mul_assoc _ _ _ }
  have : ∀ x, H.out.lift g.to_linear_map (algebraMap R' S' x) = g x := H.out.lift_eq _
  refine' AlgHom.ofLinearMap ((H.out.lift g.to_linear_map).restrictScalars R) _ _
  · dsimp only [LinearMap.restrictScalars_apply]
    rw [← (algebraMap R' S').map_one, this, g.map_one]
  · intro x y
    apply H.out.induction_on x
    · rw [MulZeroClass.zero_mul, map_zero, MulZeroClass.zero_mul]
    rotate_left
    · intro s s' e
      dsimp only [LinearMap.restrictScalars_apply] at e⊢
      rw [LinearMap.map_smul, smul_mul_assoc, LinearMap.map_smul, e, smul_mul_assoc]
    · intro s s' e₁ e₂
      dsimp only [LinearMap.restrictScalars_apply] at e₁ e₂⊢
      rw [add_mul, map_add, map_add, add_mul, e₁, e₂]
    intro x
    dsimp
    rw [this]
    apply H.out.induction_on y
    · rw [MulZeroClass.mul_zero, map_zero, MulZeroClass.mul_zero]
    · intro y
      dsimp
      rw [← _root_.map_mul, this, this, _root_.map_mul]
    · intro s s' e
      rw [mul_comm, smul_mul_assoc, LinearMap.map_smul, LinearMap.map_smul, mul_comm, e]
      change f s * (g x * _) = g x * (f s * _)
      rw [← mul_assoc, ← mul_assoc, hf]
    · intro s s' e₁ e₂
      rw [mul_add, map_add, map_add, mul_add, e₁, e₂]
#align algebra.pushout_desc Algebra.pushoutDesc

@[simp]
theorem Algebra.pushoutDesc_left [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) (x : S) :
    Algebra.pushoutDesc S' f g H (algebraMap S S' x) = f x :=
  by
  rw [Algebra.pushoutDesc_apply, Algebra.algebraMap_eq_smul_one, LinearMap.map_smul, ←
    Algebra.pushoutDesc_apply S' f g H, _root_.map_one]
  exact mul_one (f x)
#align algebra.pushout_desc_left Algebra.pushoutDesc_left

theorem Algebra.lift_algHom_comp_left [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) :
    (Algebra.pushoutDesc S' f g H).comp (toAlgHom R S S') = f :=
  AlgHom.ext fun x => (Algebra.pushoutDesc_left S' f g H x : _)
#align algebra.lift_alg_hom_comp_left Algebra.lift_algHom_comp_left

@[simp]
theorem Algebra.pushoutDesc_right [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) (x : R') :
    Algebra.pushoutDesc S' f g H (algebraMap R' S' x) = g x := by
  apply (config := { instances := false }) @IsBaseChange.lift_eq
#align algebra.pushout_desc_right Algebra.pushoutDesc_right

theorem Algebra.lift_algHom_comp_right [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] (f : S →ₐ[R] A) (g : R' →ₐ[R] A) (H) :
    (Algebra.pushoutDesc S' f g H).comp (toAlgHom R R' S') = g :=
  AlgHom.ext fun x => (Algebra.pushoutDesc_right S' f g H x : _)
#align algebra.lift_alg_hom_comp_right Algebra.lift_algHom_comp_right

@[ext]
theorem Algebra.IsPushout.algHom_ext [H : Algebra.IsPushout R S R' S'] {A : Type _} [Semiring A]
    [Algebra R A] {f g : S' →ₐ[R] A} (h₁ : f.comp (toAlgHom R R' S') = g.comp (toAlgHom R R' S'))
    (h₂ : f.comp (toAlgHom R S S') = g.comp (toAlgHom R S S')) : f = g :=
  by
  ext x
  apply H.1.inductionOn x
  · simp only [map_zero]
  · exact AlgHom.congr_fun h₁
  · intro s s' e
    rw [Algebra.smul_def, f.map_mul, g.map_mul, e]
    congr 1
    exact (AlgHom.congr_fun h₂ s : _)
  · intro s₁ s₂ e₁ e₂
    rw [map_add, map_add, e₁, e₂]
#align algebra.is_pushout.alg_hom_ext Algebra.IsPushout.algHom_ext

end IsBaseChange


import subgroup.lagrange

open_locale classical

/-
  The type of group homs G → H is
  denoted f : G →* H
  and the underlying function of types is ⇑f : G → H
  TODO: can we switch those arrows off?
  The axiom: if `f : G →* H` then `f.map_mul`
  is the assertion that for all a, b ∈ G
  we have f(a) = f(b).
  Our first job is to prove `f.map_one` and `f.map_inv`.

  `f.map_one : f 1 = 1`
  `f.map_inv {x : G} : f (x⁻¹) = f(x)⁻¹`

-/

-- the entire project takes place in the mygroup namespace
namespace mygroup

open group_hom lagrange mygroup.quotient normal
  function set mygroup.subgroup

namespace quotient

variables {G H K : Type} [group G] [group H] [group K]
variables {f : G →* H}

/-- The natural map from a group `G` to its quotient `G / N` is a homomorphism -/
def mk (N : normal G) : G →* G /ₘ N :=
{ to_fun := λ g, g,
  map_mul' := λ _ _, by apply quotient.sound; refl }

variable {N : normal G}

-- The coercion from `G` to `G /ₘ N` is exactly our `mk` group hom
@[simp] lemma coe_eq_mk (g : G) : (g : G /ₘ N) = mk N g := rfl

-- The kernel of `mk N` is `N`
lemma kernel_mk {N : normal G} : kernel (mk N) = N :=
begin
  ext x,
  show (x : G /ₘ N) = (1 : G) ↔ x ∈ N.to_subgroup,
  rw [mk_eq, ←con_one_iff_mem],
  refl,
end

/-- The natural homomorphism from a group `G` to its quotient `G / N` is a
  surjection -/
theorem is_surjective_mk : surjective $ mk N := exists_mk

-- The first isomorphism theorem states that for all `f : G →* H`,
-- `G /ₘ kernel f ≅ image f`, we will prove this here.

-- We will use `lift_on` which is the same as `quotient.lift_on'`
-- Given an equivalence relation `R` on some type `α`, and a function `f : α → β`
-- `λ (a : quotient R), quotient.lift_on' a f h` is the function that maps `⟦x⟧`
-- to `f x` where `h` is a proof that this function is well defined, i.e.
-- `∀ x y : α, ⟦x⟧ = ⟦y⟧ → f x = f y`.

/- Given a group hom `f : G →* H` and a normal subgroup `N` of `G`
with `N ⊆ kernel f`, there's an induced hom `G /ₘ N → H` -/
def lift (f : G →* H) (N : normal G) (h : N.to_subgroup ≤ kernel f) :
G /ₘ N →* H :=
{ to_fun := λ x, lift_on x f
  begin
    intros x y h1,
    rw [con_of_normal_def, lcoset_rel_def, lcoset_eq] at h1,
    specialize h h1,
    change y⁻¹ * x ∈ f.kernel at h,
    rw mem_kernel at h,
    rw [map_mul, map_inv] at h,
    apply group.mul_left_cancel (f y)⁻¹,
    rw h, simp
  end,
  map_mul' := λ a b, quotient.induction_on₂' a b f.map_mul }

@[simp] lemma lift_mk {f : G →* H} (N : normal G) (h : N.to_subgroup ≤ kernel f)
  (g : G) : lift f N h (mk N g) = f g := rfl

lemma lift_image {f : G →* H} {N : normal G} (h : N.to_subgroup ≤ kernel f) :
  (lift f N h).image = f.image :=
begin
  ext x, split,
  { rintro ⟨a, rfl⟩,
    rcases exists_mk a with ⟨g, rfl⟩,
    exact group_hom.mem_image.2 ⟨g, rfl⟩ },
  { rintro ⟨a, rfl⟩,
    exact ⟨(mk N a), rfl⟩ }
end

-- For the first isomorphism theorem, we will define a specific version of the
-- `lift` homomorphism above with `N = kernel f`

-- First we prove such a map is well defined
lemma map_of_lcoset_eq {f : G →* H} {x y : G}
  (hxy : x ⋆ kernel f = y ⋆ kernel f) : f x = f y :=
begin
  rw [←group.mul_left_cancel_iff (f y)⁻¹,
      ←map_inv, ←map_mul, map_inv, group.mul_left_inv,
      ←mem_kernel],
  exact lcoset_eq.1 hxy
end

/-- Given a group homomorphism `f : G →* H`, `kernel_lift f` is a mapping from
  the quotient `G /ₘ kernel f` to `H` such that `x ⋆ kernel f ↦ f x` -/
def kernel_lift (f : G →* H) (x : G /ₘ kernel f) := lift_on x f $
  λ _ _, map_of_lcoset_eq

@[simp] lemma kernel_lift_mk {f : G →* H} (g : G) :
  kernel_lift f (g : G /ₘ kernel f) = f g := rfl

/-- Given a group homomorphism `f : G →* H`, `kernel_lift f` form a homomorphism
  `kernel_lift_hom f` from `(G /ₘ kernel f) →* H` -/
def kernel_lift_hom (f : G →* H) : (G /ₘ kernel f) →* H :=
{ to_fun := kernel_lift f,
  map_mul' := λ x y, quotient.induction_on₂' x y $ λ _ _,
    by simp only [quotient.coe, quotient.coe_mul, kernel_lift_mk, map_mul] }

/-- `kernel_lift_hom f` is an injective homomorphism -/
lemma injective_of_kernel_lift_hom {f : G →* H} :
  injective $ kernel_lift_hom f :=
begin
  intros x y,
  apply quotient.induction_on₂' x y,
  intros _ _ hab,
  change kernel_lift f a₁ = kernel_lift f a₂ at hab,
  iterate 2 { rw kernel_lift_mk at hab, rw quotient.coe },
  rw [mk_eq, lcoset_eq],
  exact mem_kernel_of_eq hab
end

/-- An alternative to `kernel_lift_hom` in which the range is restricted to the
  image of `f` so that the homomorphism is also surjective -/
def kernel_lift_hom' (f : G →* H) : (G /ₘ kernel f) →* f.image :=
{ to_fun := λ q, ⟨kernel_lift f q, quotient.induction_on' q $
    λ a, show f a ∈ f.image, by exact ⟨a, rfl⟩⟩,
  map_mul' := λ x y, quotient.induction_on₂' x y $ λ _ _,
    by simpa only [quotient.coe, quotient.coe_mul, kernel_lift_mk, map_mul] }

lemma kernel_lift_hom'_eq_kernel_lift_hom {f : G →* H} (q : G /ₘ kernel f) :
  (kernel_lift_hom' f q : H) = kernel_lift_hom f q := rfl

lemma injective_of_kernel_lift_hom' {f : G →* H} :
  injective $ kernel_lift_hom' f := λ x y hxy, injective_of_kernel_lift_hom $
by iterate 2 { rw ←kernel_lift_hom'_eq_kernel_lift_hom }; rw hxy

lemma surjective_of_kernel_lift_hom' {f : G →* H} :
  surjective $ kernel_lift_hom' f := λ ⟨_, x, rfl⟩, ⟨x, kernel_lift_mk x⟩

/-- Given a group homomorphism `f`, `kernel_lift_hom' f` is a bijection -/
lemma bijective_of_kernel_lift_hom' {f : G →* H} :
  bijective $ kernel_lift_hom' f :=
⟨injective_of_kernel_lift_hom', surjective_of_kernel_lift_hom'⟩

/-- The first isomorphism theorem: `G /ₘ kernel f ≅ image f` for `f : G →* H`
  a group homomorphism -/
def kernel_iso_image (f : G →* H) :
  G /ₘ kernel f ≅ image f :=
{ is_bijective := bijective_of_kernel_lift_hom',
  .. kernel_lift_hom' f }

-- The image of a surjective homomorphism is isomorphic to the group its mapped to
def iso_of_surjective {f : G →* H} (hf : surjective f) : image f ≅ H :=
{ is_bijective := ⟨ injective_𝒾, λ y,
    ⟨⟨y, show y ∈ range f, by simp [hf y]⟩, by simp [𝒾]⟩ ⟩,
  .. 𝒾 $ image f }

/-- The first isomorphism theorem with a surjective homomorphism:
  `G /ₘ kernel f ≅ H` for `f : G →* H` a surjective group homomorphism-/
def kernel_iso_of_surjective {f : G →* H} (hf : surjective f) :
  G /ₘ kernel f ≅ H :=
iso_comp (kernel_iso_image f) $ iso_of_surjective hf

def subst_iso {A B : normal G} (h : A = B) : G /ₘ A ≅ G /ₘ B :=
{ is_bijective := begin subst h, convert bijective_id, ext x, rcases x, refl end,
  ..(lift (mk B) A (by {rw [h, kernel_mk], refl'})) }

def subst_iso' {A B : normal G} (h : A = B) (f : G /ₘ A ≅ H) : G /ₘ B ≅ H :=
iso_comp (subst_iso h.symm) f

def kernel_iso_of_surjective' {f : G →* H} (hf : surjective f)
{N : normal G} (hN : kernel f = N) :
  G /ₘ N ≅ H := subst_iso' hN $ kernel_iso_of_surjective hf

/-- If `N ⊆ kernel f` then the kernel of induced map `lift f N h` is
  image of `kernel f` -/
lemma lift_kernel {f : G →* H} {N : normal G} (h : N.to_subgroup ≤ kernel f) :
  kernel (lift f N h) = nmap is_surjective_mk (kernel f) :=
begin
  ext x, split,
  { intro h2, rcases quotient.exists_mk x with ⟨g, rfl⟩,
    rw coe_eq_mk at *, rw [mem_kernel, lift_mk] at h2,
    refine ⟨g, mem_kernel.2 h2, rfl⟩ },
  { rintro ⟨g, hg1, rfl⟩,
    change g ∈ f.kernel at hg1,
    rw mem_kernel at *, rw lift_mk, assumption }
end

/-
  The way to think about the formulation of the second isomorphism theorem is
  think about the individual mappings.

  First let us think about what `comap (𝒾 T) N` represents.
  `comap f N` is the normal subgroup whose underlying set is the preimage of `N`
  alongside `f`, so `comap (𝒾 T) N` is the normal subgroup of `T` that gets
  mapped into `N` under the inclusion map, i.e. elements in `T ∩ N`.

  Now let us consider `comap (𝒾 (T ⊔ N)) N` which is similar.

  Again the the `comap (𝒾 (T ⊔ N)) N` is the preimage along the inclusion map
  `𝒾 (T ⊔ N)`. But this this time we see that `N ⊆ T ⊔ N`so their intersection
  are is just `N`.

  So why are we going through this trouble just to get back to `N`? The reason
  is that we have defined quotients to be an operation on a group and its normal
  subgroups. Notice that `comap (𝒾 (T ⊔ N)) N` does not have the same type as `N`.
  While `N` has type `normal G`, `comap (𝒾 (T ⊔ N)) N` has type `normal (T ⊔ N)`
  as demonstrated by the diagramme above. This is the type we need since we
  can only quotient `T ⊔ N` by one of its normal subgroups.
-/

-- Proving the second isomorphism theorem using the first

-- `aux_hom` is the natural group homomorphism that maps `t : T` to
-- `(t : T ⨯ N) : (T ⨯ N) /ₘ comap (𝒾 (T ⨯ N)) N`
def aux_hom (T : subgroup G) (N : normal G) :
  T →* ↥(T ⨯ N) /ₘ comap (𝒾 (T ⨯ N)) N := (mk _) ∘* (to_prod T N)

@[simp] lemma aux_hom_def {T : subgroup G} {N : normal G} (g) :
  aux_hom T N g = (mk _) (to_prod T N g) := rfl

-- `aux_hom` has kernel `comap (𝒾 T) N` or equivalently `T ⊓ N`
lemma aux_hom_kernel {T : subgroup G} {N : normal G} :
  kernel (aux_hom T N) = comap (𝒾 T) N :=
begin
  ext, split;
    { rw [mem_kernel, aux_hom_def, ←coe_eq_mk, ←coe_one, mk_eq'],
      intro hx, simpa using hx }
end

-- `aux_hom` is a surjective homomorphism
lemma aux_hom_surjective (T : subgroup G) (N : normal G) :
  surjective $ aux_hom T N :=
begin
  intro y,
  rcases exists_mk y with ⟨g, rfl⟩,
  rcases g with ⟨_, t, ht, n, hn, rfl⟩,
  refine ⟨⟨t, ht⟩, _⟩,
  rw [aux_hom_def, ←coe_eq_mk, mk_eq'],
  simp [group.mul_assoc, show n⁻¹ ∈ N, by exact inv_mem (N : subgroup G) hn]
end

def second_iso_theorem (T : subgroup G) (N : normal G) :
  T /ₘ comap (𝒾 T) N ≅ ↥(T ⨯ N) /ₘ comap (𝒾 (T ⨯ N)) N :=
kernel_iso_of_surjective' (aux_hom_surjective T N) aux_hom_kernel

-- To state the third isomorphism theorem we need to be able to push forward
-- (`map`) a normal subgroup along a surjection

def third_iso_theorem (T : normal G) (N : normal G) (h : T.to_subgroup ≤ N) :
  let NmodT : normal (G /ₘ T) := N.nmap is_surjective_mk in
   (G /ₘ T) /ₘ NmodT ≅ G /ₘ N :=
let f : G /ₘ T →* G /ₘ N := (lift (mk N) _ (by { convert h, rw kernel_mk })) in
iso_comp (subst_iso $
    show nmap is_surjective_mk N = f.kernel, by rw [lift_kernel, kernel_mk]) $
  kernel_iso_of_surjective
    (by { rw [surjective_iff_max_img, lift_image, ←surjective_iff_max_img],
      exact is_surjective_mk })

-- We would like to define `correspondence N : H ↦ H /ₘ N` so first we need to
-- show if `H : subgroup G` with `(N : subgroup G) ≤ H`, then `↑N` is a normal
-- subgroup of `H`

-- I think what I need it a way to make a subgroup from a group, i.e. given `G`
-- and `H` both groups, if there is a map from `H` to `G`, `f` then there
-- is a induced subgroup of `G` from `H` using `image f`

/-- `qmap` is a group homomorphism from `H /ₘ N →* G /ₘ N` where `H : subgroup G`
  and `N : normal G` such that `h ⋆ N ↦ h ⋆ N` -/
def qmap (H : subgroup G) (N : normal G) : H /ₘ comap (𝒾 H) N →* G /ₘ N :=
  let φ : H →* G /ₘ N := ⟨λ h, mk N h.1, λ _ _, rfl⟩ in lift φ (comap (𝒾 H) N) $
begin
  rintro ⟨x, hx₀⟩ hx,
  show _ ∈ kernel φ,
  rw mem_kernel,
  show mk N x = 1,
  rw [←coe_eq_mk, ←coe_one, mk_eq'],
  change _ ∈ normal.comap (𝒾 H) N at hx,
  simp * at *,
end

@[simp] lemma qmap_eq {H : subgroup G} {N : normal G} (h : H) :
  qmap H N h = mk N h := rfl

lemma mem_qmap_image {H : subgroup G} {N : normal G} (h) :
  h ∈ (qmap H N).image ↔ ∃ (g : H /ₘ comap (𝒾 H) N), qmap H N g = h := iff.rfl

lemma injective_qmap {H : subgroup G} {N : normal G} : injective $ qmap H N :=
begin
  intros x y hxy,
  rcases exists_mk x with ⟨x, rfl⟩,
  rcases exists_mk y with ⟨y, rfl⟩,
  change mk N x = mk N y at hxy,
  rw [←coe_eq_mk, ←coe_eq_mk, mk_eq'] at hxy,
  rw [mk_eq', mem_comap],
  exact hxy
end

def correspondence (N : normal G) :
  subgroup_ge G N → subgroup_ge (G /ₘ N) ⊥ := λ ⟨H, hH⟩,
subgroup_ge.mk (image $ qmap H N) bot_le

def correspondence_inv (N : normal G) :
  subgroup_ge (G /ₘ N) ⊥ → subgroup_ge G N := λ ⟨H, hH⟩,
subgroup_ge.mk (subgroup.comap (mk N) H) $
  λ n hn, show mk N n ∈ H,
  by { convert one_mem H, rw [←mem_kernel, kernel_mk], exact hn }

lemma correspondence_left_inv (N : normal G) :
  left_inverse (correspondence_inv N) (correspondence N) :=
begin
  rintro ⟨H, hH⟩,
  suffices : comap (mk N) (qmap H N).image = H,
   { simpa [correspondence, correspondence_inv] },
  ext x, split; intro hx,
   { cases hx with x' hx', rcases exists_mk x' with ⟨g, rfl⟩,
     rw [qmap_eq, ←coe_eq_mk, ←coe_eq_mk, mk_eq'] at hx',
     rw ←group.inv_inv x,
     refine inv_mem H _,
     rw [←group.mul_one x⁻¹, ←group.mul_right_inv (g : G), ←group.mul_assoc],
     exact mul_mem H (hH hx') (inv_mem H g.2) },
   { refine ⟨((⟨x, hx⟩ : H) : H /ₘ comap (𝒾 H) N), _⟩,
     rw qmap_eq, refl }
end

lemma correspondence_right_inv (N : normal G) :
  right_inverse (correspondence_inv N) (correspondence N) :=
begin
  rintro ⟨H, _⟩,
  suffices : (qmap (comap (mk N) H) N).image = H,
    { simpa [correspondence, correspondence_inv] },
  ext x, split; intro hx,
    { rcases hx with ⟨x', rfl⟩,
      rcases exists_mk x' with ⟨⟨g, hg⟩, rfl⟩,
      exact hg },
    { rcases exists_mk x with ⟨g, rfl⟩,
      exact ⟨(mk (comap (𝒾 (comap (mk N) H)) N)) ⟨g, hx⟩, rfl⟩ }
end

def subgroups_of_quotient_equiv (N : normal G) :
  subgroup_ge G N ≃ subgroup_ge (G /ₘ N) ⊥ :=
{ to_fun := correspondence N,
  inv_fun := correspondence_inv N,
  left_inv := correspondence_left_inv N,
  right_inv := correspondence_right_inv N }

def subgroup.gc (N : normal G) : galois_connection (subgroups_of_quotient_equiv N).to_fun
  (subgroups_of_quotient_equiv N).inv_fun :=
begin
  intros A B,
  cases A with A hA,
  cases B with B _,
  split; intros h a ha,
    { exact h ⟨((⟨a, ha⟩ : A) : _), rfl⟩ },
    { rcases ha with ⟨x, rfl⟩,
      rcases exists_mk x with ⟨⟨g, hg⟩, rfl⟩,
      exact h hg }
end

-- ↓ This turns out to be useless since gc + equiv = order_iso ⇒ gi...
def subgroup.gi (N : normal G) : galois_insertion (subgroups_of_quotient_equiv N).to_fun
  (subgroups_of_quotient_equiv N).inv_fun :=
{ choice := λ x _, (subgroups_of_quotient_equiv N).to_fun x,
  gc := subgroup.gc N,
  le_l_u := λ x, by { rw (subgroups_of_quotient_equiv N).right_inv, exact le_refl _ },
  choice_eq := λ _ _, rfl }

/-- The subgroups of `G` greater than some `N : normal G` is order isomorphic to
  the subgroups of `G /ₘ N` greater than `⊥` -/
def subgroups_of_quotient_order_iso (N : normal G) :
  let A := subgroup_ge G N in
  let B := subgroup_ge (G /ₘ N) ⊥ in
  ((≤) : A → A → Prop) ≃o ((≤) : B → B → Prop) :=
lattice.order_iso_of_equiv_gi (subgroups_of_quotient_equiv N) (subgroup.gc N)

/-- The subgroups of `G` greater than some `N : normal G` is order isomorphic to
  the subgroups of `G /ₘ N` -/
def subgroups_of_quotient_order_iso' (N : normal G) :
  let A := subgroup_ge G N in
  let B := subgroup (G /ₘ N) in
  ((≤) : A → A → Prop) ≃o ((≤) : B → B → Prop) :=
order_iso.trans (subgroups_of_quotient_order_iso N) $
  order_iso.symm ge.subgroup_ge_bot_order_iso

-- We would like a lemma that states : Given `G` groups, `N : normal G`, the
-- preimage of `H : subgroup G /ₘ N` under the natural map from `G` to `G /ₘ N`
-- is a subgroup of `G` with order `|H||N|`.

def comap (N : normal G) (H : subgroup (G /ₘ N)) : subgroup G :=
  subgroup.comap (mk N) H

lemma comap_le (N : normal G) (H : subgroup (G /ₘ N)) :
  (N : set G) ⊆ quotient.comap N H := λ n hn,
show _ ∈ H, by { convert one_mem H, rw [← mem_kernel, kernel_mk], exact hn }

-- The way to think about this is that `mk⁻¹ H` is the new group with `N` its
-- normal subgroup. Now, by `kernel_mk` we have `kernel mk = N` so by the
-- first isomorphism theorem `mk⁻¹ H /ₘ N ≅ H`

lemma quotient.comap_iso (N : normal G) (H : subgroup (G /ₘ N)) :
  quotient.comap N H /ₘ normal.comap (𝒾 $ quotient.comap N H) N ≅ H :=
  let f : quotient.comap N H →* H :=
    { to_fun := λ x, ⟨mk N x.1, x.2⟩,
      map_mul' := λ _ _, rfl } in
  kernel_iso_of_surjective' (begin
    rintro ⟨y, hy⟩,
    rcases exists_mk y with ⟨g, rfl⟩,
    use [g, hy], refl
  end : surjective f)
  begin
    ext x,
    rw [mem_kernel, mem_comap],
    unfold coe_fn has_coe_to_fun.coe,
    simp only [to_fun_eq_coe, subtype.val_eq_coe],
    cases x with x hx,
    change _ ↔ x ∈ N,
    conv_rhs begin rw ←@kernel_mk _ _ N, end,
    rw mem_kernel,
    show _ = (⟨(1 : G /ₘ N), _⟩ : H) ↔ _, simp
  end

lemma comap_card_eq [fintype G] (N : normal G) (H : subgroup (G /ₘ N)) :
  fincard (quotient.comap N H) =
  fincard (normal.comap (𝒾 $ quotient.comap N H) N) * fincard H :=
begin
  rw [fincard.of_equiv (mul_equiv_of_iso (iso_symm (quotient.comap_iso N H))).to_equiv,
     ← lagrange.card_quotient_eq_mul]
end

-- I would like a theorem that states given `N : normal G` where `N` is the largest
-- proper subgroup of `G`, then `G /ₘ N` is simple.

def ncorrespondence (N : normal G) :
  { H : normal G // N ≤ H } → normal (G /ₘ N) := λ ⟨H, hH⟩,
nmap is_surjective_mk H

def ncorrespondence_inv (N : normal G) :
  normal (G /ₘ N) → { H : normal G // N ≤ H } := λ H,
⟨ normal.comap (mk N) H,
  begin
    intros n hn,
    erw mem_comap,
    change n ∈ N at hn,
    rw ← @kernel_mk _ _ N at hn,
    convert H.one_mem',
  end ⟩

@[simp] lemma ncorrespondence_def (N : normal G) (M : { H : normal G // N ≤ H }) :
  ncorrespondence N M = nmap is_surjective_mk M.val := by cases M; refl

@[simp] lemma ncorrespondence_inv_def (N : normal G) (H : normal (G /ₘ N)) :
  (ncorrespondence_inv N H).val = normal.comap (mk N) H := rfl

lemma ncorrespondence_left_inv (N : normal G) :
  left_inverse (ncorrespondence_inv N) (ncorrespondence N) :=
begin
  rintro ⟨H, hH⟩,
  unfold ncorrespondence,
  unfold ncorrespondence_inv,
  congr,
  ext x, split; intro hx,
  { rcases hx with ⟨x', hx'₀, hx'₁⟩,
    rw [← coe_eq_mk, ← coe_eq_mk] at hx'₁,
    rw [show x = x' * (x'⁻¹ * x), by simp],
    exact H.mul_mem' hx'₀ (hH (mk_eq'.1 hx'₁.symm)) },
   { tidy }
end

lemma ncorrespondence_right_inv (N : normal G) :
  right_inverse (ncorrespondence_inv N) (ncorrespondence N) :=
begin
  rintro H,
  unfold ncorrespondence_inv,
  unfold ncorrespondence,
  ext x, split; intro hx,
    { rw mem_nmap at hx,
      rcases hx with ⟨_, hg, rfl⟩,
      exact hg },
    { tidy }
end

def normal_of_quotient_equiv (N : normal G) :
  { H : normal G // N ≤ H } ≃ normal (G /ₘ N) :=
{ to_fun := ncorrespondence N,
  inv_fun := ncorrespondence_inv N,
  left_inv := ncorrespondence_left_inv N,
  right_inv := ncorrespondence_right_inv N }

@[simp] lemma normal_of_quotient_equiv_to_fun_def (N : normal G) :
  (normal_of_quotient_equiv N).to_fun = ncorrespondence N := rfl

@[simp] lemma normal_of_quotient_equiv_inv_fun_def (N : normal G) :
  (normal_of_quotient_equiv N).inv_fun = ncorrespondence_inv N := rfl

def normal.gc (N : normal G) : galois_connection (normal_of_quotient_equiv N).to_fun
  (normal_of_quotient_equiv N).inv_fun :=
begin
  intros A B,
  cases A with A hA,
  split; rintros h a ha,
    { apply h, tidy },
    { change A ≤ _ at h,
      rw [normal_of_quotient_equiv_to_fun_def, ncorrespondence_def] at ha,
      rcases ha with ⟨g, hg, rfl⟩,
      exact h hg }
end

def normal_of_quotient_order_iso (N : normal G) :
  let A := { H : normal G // N ≤ H }in
  let B := normal (G /ₘ N) in
  ((≤) : A → A → Prop) ≃o ((≤) : B → B → Prop) :=
lattice.order_iso_of_equiv_gi (normal_of_quotient_equiv N) (normal.gc N)

end quotient

end mygroup


import data.set.finite
import data.finset.basic

variables {V V' V'' : Type*}
local attribute [instance] classical.prop_decidable

open set finset

/--
A function is *cofinite* if the pre-image of every point is a finite set.

Equivalently, as proved below, a function is *cofinite* if the pre-image of every
finite set is finite.
-/
def cofinite (f : V → V') := ∀ x : V', (set.preimage f {x}).finite

lemma cofinite.list_preimage (f : V → V') (cof : cofinite f) : ∀ l : list V', (set.preimage f l.to_finset).finite :=
begin
  intro l,
  induction l,
  { simp only [list.to_finset_nil, coe_empty, set.preimage_empty, finite_empty], },
  { simp only [list.to_finset_cons, coe_insert],
    rw [set.insert_eq, set.preimage_union],
    apply set.finite.union,
    {apply cof,},
    {assumption,} }
end

/--
The preimage of a finite set under a *cofinite* map is finite.
-/
lemma cofinite.finite_preimage (f : V → V') (cof : cofinite f) : ∀ S : set V', S.finite → (set.preimage f S).finite :=
begin
  intros S Sfin,
  rcases set.finite.exists_finset_coe Sfin with ⟨fS, hcoefin⟩,
  rcases (list.to_finset_surjective fS) with ⟨l, hcoelst⟩,
  rw [← hcoefin, ← hcoelst],
  apply cofinite.list_preimage _ cof,
end

/--
A function is *cofinite* if and only if the pre-image of any finite set is finite.
-/
lemma cofinite.finite_preimage_iff (f : V → V') : cofinite f ↔ ∀ S : set V', S.finite → (set.preimage f S).finite :=
⟨cofinite.finite_preimage _, λ h x, h {x} (set.finite_singleton x)⟩

/-- The composition of cofinite maps is cofinite. -/
lemma cofinite.comp {f : V → V'} {f' : V' → V''} (cof : cofinite f) (cof' : cofinite f') : cofinite (f' ∘ f) :=
begin
  intro x,
  rw [set.preimage_comp],
  apply cofinite.finite_preimage _ cof,
  apply cof',
end

/-- The identity map is cofinite. -/
lemma cofinite.id : cofinite (@id V) := by {intro,simp only [set.preimage_id, finite_singleton]}
/-- An injective map is cofinite. -/
lemma cofinite.of_inj {f : V → V'} (inj : function.injective f) : cofinite f := by
{ intro,
  refine subsingleton.finite _,
  refine (function.injective.subsingleton_image_iff inj).mp _,
  tidy, } -- can we show it constructively?

/-- `cofinite.preimage` computes the preimage of a finite set under a cofinite map (as a `finset`). -/
noncomputable def cofinite.preimage {f : V → V'} (cof : cofinite f) (K : finset V') : finset V :=
set.finite.to_finset (cofinite.finite_preimage f cof K (finset.finite_to_set K))

/-- The value of `cofinite.preimage is the preimage of the cofinite function. -/
@[simp]
lemma cofinite.preimage.coe {f : V → V'} (cof : cofinite f) (K : finset V') : ↑(cof.preimage K) = set.preimage f K :=
begin
  show ↑(set.finite.to_finset (cofinite.finite_preimage f cof K (finset.finite_to_set K))) = f⁻¹' ↑K,
  simp,
end

/-- The direct image of an infinite set under a cofinite map is infinite. -/
lemma cofinite.image_infinite {f : V → V'} (cof : cofinite f) {S : set V} (Sinf : S.infinite) :
  (f '' S).infinite :=
begin
  intro hfin, apply Sinf,
  have := cofinite.finite_preimage _ cof _ hfin,
  refine finite.subset this _,
  exact subset_preimage_image f S,
end


/-
Copyright (c) 2021 Yaël Dillies, Bhavik Mehta. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yaël Dillies, Bhavik Mehta
-/
import analysis.convex.combination
import analysis.convex.extreme

/-!
# Convex independence

This file defines convex independent families of points.

Convex independence is closely related to affine independence. In both cases, no point can be
written as a combination of others. When the combination is affine (that is, any coefficients), this
yields affine independence. When the combination is convex (that is, all coefficients are
nonnegative), then this yields convex independence. In particular, affine independence implies
convex independence.

## Main declarations

* `convex_independent p`: Convex independence of the indexed family `p : ι → E`. Every point of the
  family only belongs to convex hulls of sets of the family containing it.
* `convex_independent_iff_finset`: Carathéodory's theorem allows us to only check finsets to
  conclude convex independence.
* `convex.extreme_points_convex_independent`: Extreme points of a convex set are convex independent.

## References

* https://en.wikipedia.org/wiki/Convex_position

## TODO

Prove `affine_independent.convex_independent`. This requires some glue between `affine_combination`
and `finset.center_mass`.

## Tags

independence, convex position
-/

open_locale affine big_operators classical
open finset function
variables {𝕜 E ι : Type*}

section ordered_semiring
variables (𝕜) [ordered_semiring 𝕜] [add_comm_group E] [module 𝕜 E] {s t : set E}

/-- An indexed family is said to be convex independent if every point only belongs to convex hulls
of sets containing it. -/
def convex_independent (p : ι → E) : Prop :=
∀ (s : set ι) (x : ι), p x ∈ convex_hull 𝕜 (p '' s) → x ∈ s

variables {𝕜}

/-- A family with at most one point is convex independent. -/
lemma subsingleton.convex_independent [subsingleton ι] (p : ι → E) :
  convex_independent 𝕜 p :=
λ s x hx, begin
  have : (convex_hull 𝕜 (p '' s)).nonempty := ⟨p x, hx⟩,
  rw [convex_hull_nonempty_iff, set.nonempty_image_iff] at this,
  rwa subsingleton.mem_iff_nonempty,
end

/-- A convex independent family is injective. -/
protected lemma convex_independent.injective {p : ι → E} (hc : convex_independent 𝕜 p) :
  function.injective p :=
begin
  refine λ i j hij, hc {j} i _,
  rw [hij, set.image_singleton, convex_hull_singleton],
  exact set.mem_singleton _,
end

/-- If a family is convex independent, so is any subfamily given by composition of an embedding into
index type with the original family. -/
lemma convex_independent.comp_embedding {ι' : Type*} (f : ι' ↪ ι) {p : ι → E}
  (hc : convex_independent 𝕜 p) :
  convex_independent 𝕜 (p ∘ f) :=
begin
  intros s x hx,
  rw ←f.injective.mem_set_image,
  exact hc _ _ (by rwa set.image_image),
end

/-- If a family is convex independent, so is any subfamily indexed by a subtype of the index type.
-/
protected lemma convex_independent.subtype {p : ι → E} (hc : convex_independent 𝕜 p) (s : set ι) :
  convex_independent 𝕜 (λ i : s, p i) :=
hc.comp_embedding (embedding.subtype _)

/-- If an indexed family of points is convex independent, so is the corresponding set of points. -/
protected lemma convex_independent.range {p : ι → E} (hc : convex_independent 𝕜 p) :
  convex_independent 𝕜 (λ x, x : set.range p → E) :=
begin
  let f : set.range p → ι := λ x, x.property.some,
  have hf : ∀ x, p (f x) = x := λ x, x.property.some_spec,
  let fe : set.range p ↪ ι := ⟨f, λ x₁ x₂ he, subtype.ext (hf x₁ ▸ hf x₂ ▸ he ▸ rfl)⟩,
  convert hc.comp_embedding fe,
  ext,
  rw [embedding.coe_fn_mk, comp_app, hf],
end

/-- A subset of a convex independent set of points is convex independent as well. -/
protected lemma convex_independent.mono {s t : set E} (hc : convex_independent 𝕜 (λ x, x : t → E))
  (hs : s ⊆ t) :
  convex_independent 𝕜 (λ x, x : s → E) :=
hc.comp_embedding (s.embedding_of_subset t hs)

/-- The range of an injective indexed family of points is convex independent iff that family is. -/
lemma function.injective.convex_independent_iff_set {p : ι → E}
  (hi : function.injective p) :
  convex_independent 𝕜 (λ x, x : set.range p → E) ↔ convex_independent 𝕜 p :=
⟨λ hc, hc.comp_embedding
  (⟨λ i, ⟨p i, set.mem_range_self _⟩, λ x y h, hi (subtype.mk_eq_mk.1 h)⟩ : ι ↪ set.range p),
  convex_independent.range⟩

/-- If a family is convex independent, a point in the family is in the convex hull of some of the
points given by a subset of the index type if and only if the point's index is in this subset. -/
@[simp] protected lemma convex_independent.mem_convex_hull_iff {p : ι → E}
    (hc : convex_independent 𝕜 p) (s : set ι) (i : ι) :
  p i ∈ convex_hull 𝕜 (p '' s) ↔ i ∈ s :=
⟨hc _ _, λ hi, subset_convex_hull 𝕜 _ (set.mem_image_of_mem p hi)⟩

/-- If a family is convex independent, a point in the family is not in the convex hull of the other
points. See `convex_independent_set_iff_not_mem_convex_hull_diff` for the `set` version.  -/
lemma convex_independent_iff_not_mem_convex_hull_diff {p : ι → E} :
  convex_independent 𝕜 p ↔ ∀ i s, p i ∉ convex_hull 𝕜 (p '' (s \ {i})) :=
begin
  refine ⟨λ hc i s h, _, λ h s i hi, _⟩,
  { rw hc.mem_convex_hull_iff at h,
    exact h.2 (set.mem_singleton _) },
  { by_contra H,
    refine h i s _,
    rw set.diff_singleton_eq_self H,
    exact hi }
end

lemma convex_independent_set_iff_inter_convex_hull_subset {s : set E} :
  convex_independent 𝕜 (λ x, x : s → E) ↔ ∀ t, t ⊆ s → s ∩ convex_hull 𝕜 t ⊆ t :=
begin
  split,
  { rintro hc t h x ⟨hxs, hxt⟩,
    refine hc {x | ↑x ∈ t} ⟨x, hxs⟩ _,
    rw subtype.coe_image_of_subset h,
    exact hxt },
  { intros hc t x h,
    rw ←subtype.coe_injective.mem_set_image,
    exact hc (t.image coe) (subtype.coe_image_subset s t) ⟨x.prop, h⟩ }
end

/-- If a set is convex independent, a point in the set is not in the convex hull of the other
points. See `convex_independent_iff_not_mem_convex_hull_diff` for the indexed family version.  -/
lemma convex_independent_set_iff_not_mem_convex_hull_diff {s : set E} :
  convex_independent 𝕜 (λ x, x : s → E) ↔ ∀ x ∈ s, x ∉ convex_hull 𝕜 (s \ {x}) :=
begin
  rw convex_independent_set_iff_inter_convex_hull_subset,
  split,
  { rintro hs x hxs hx,
    exact (hs _ (set.diff_subset _ _) ⟨hxs, hx⟩).2 (set.mem_singleton _) },
  { rintro hs t ht x ⟨hxs, hxt⟩,
    by_contra h,
    exact hs _ hxs (convex_hull_mono (set.subset_diff_singleton ht h) hxt) }
end

end ordered_semiring

section linear_ordered_field
variables [linear_ordered_field 𝕜] [add_comm_group E] [module 𝕜 E] {s : set E}

/-- To check convex independence, one only has to check finsets thanks to Carathéodory's theorem. -/
lemma convex_independent_iff_finset {p : ι → E} :
  convex_independent 𝕜 p
  ↔ ∀ (s : finset ι) (x : ι), p x ∈ convex_hull 𝕜 (s.image p : set E) → x ∈ s :=
begin
  refine ⟨λ hc s x hx, hc s x _, λ h s x hx, _⟩,
  { rwa finset.coe_image at hx },
  have hp : injective p,
  { rintro a b hab,
    rw ←mem_singleton,
    refine h {b} a _,
    rw [hab, image_singleton, coe_singleton, convex_hull_singleton],
    exact set.mem_singleton _ },
  rw convex_hull_eq_union_convex_hull_finite_subsets at hx,
  simp_rw set.mem_Union at hx,
  obtain ⟨t, ht, hx⟩ := hx,
  rw ←hp.mem_set_image,
  refine ht _,
  suffices : x ∈ t.preimage p (hp.inj_on _),
  { rwa [mem_preimage, ←mem_coe] at this },
  refine h _ x _,
  rwa [t.image_preimage p (hp.inj_on _), filter_true_of_mem],
  { exact λ y hy, s.image_subset_range p (ht $ mem_coe.2 hy) }
end

/-! ### Extreme points -/

lemma convex.convex_independent_extreme_points (hs : convex 𝕜 s) :
  convex_independent 𝕜 (λ p, p : s.extreme_points 𝕜 → E) :=
convex_independent_set_iff_not_mem_convex_hull_diff.2 $ λ x hx h,
  (extreme_points_convex_hull_subset
  (inter_extreme_points_subset_extreme_points_of_subset (convex_hull_min
  ((set.diff_subset _ _).trans extreme_points_subset) hs) ⟨h, hx⟩)).2 (set.mem_singleton _)

end linear_ordered_field


/-
Copyright (c) 2020 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad, Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.set.basic
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# Well-founded relations

A relation is well-founded if it can be used for induction: for each `x`, `(∀ y, r y x → P y) → P x`
implies `P x`. Well-founded relations can be used for induction and recursion, including
construction of fixed points in the space of dependent functions `Π x : α , β x`.

The predicate `well_founded` is defined in the core library. In this file we prove some extra lemmas
and provide a few new definitions: `well_founded.min`, `well_founded.sup`, and `well_founded.succ`.
-/

namespace well_founded

/-- If `r` is a well-founded relation, then any nonempty set has a minimal element
with respect to `r`. -/
theorem has_min {α : Type u_1} {r : α → α → Prop} (H : well_founded r) (s : set α) :
    set.nonempty s → ∃ (a : α), ∃ (H : a ∈ s), ∀ (x : α), x ∈ s → ¬r x a :=
  sorry

/-- A minimal element of a nonempty set in a well-founded order -/
def min {α : Type u_1} {r : α → α → Prop} (H : well_founded r) (p : set α) (h : set.nonempty p) :
    α :=
  classical.some (has_min H p h)

theorem min_mem {α : Type u_1} {r : α → α → Prop} (H : well_founded r) (p : set α)
    (h : set.nonempty p) : min H p h ∈ p :=
  sorry

theorem not_lt_min {α : Type u_1} {r : α → α → Prop} (H : well_founded r) (p : set α)
    (h : set.nonempty p) {x : α} (xp : x ∈ p) : ¬r x (min H p h) :=
  sorry

theorem well_founded_iff_has_min {α : Type u_1} {r : α → α → Prop} :
    well_founded r ↔
        ∀ (p : set α), set.nonempty p → ∃ (m : α), ∃ (H : m ∈ p), ∀ (x : α), x ∈ p → ¬r x m :=
  sorry

theorem eq_iff_not_lt_of_le {α : Type u_1} [partial_order α] {x : α} {y : α} :
    x ≤ y → y = x ↔ ¬x < y :=
  sorry

theorem well_founded_iff_has_max' {α : Type u_1} [partial_order α] :
    well_founded gt ↔
        ∀ (p : set α),
          set.nonempty p → ∃ (m : α), ∃ (H : m ∈ p), ∀ (x : α), x ∈ p → m ≤ x → x = m :=
  sorry

theorem well_founded_iff_has_min' {α : Type u_1} [partial_order α] :
    well_founded Less ↔
        ∀ (p : set α),
          set.nonempty p → ∃ (m : α), ∃ (H : m ∈ p), ∀ (x : α), x ∈ p → x ≤ m → x = m :=
  well_founded_iff_has_max'

/-- The supremum of a bounded, well-founded order -/
protected def sup {α : Type u_1} {r : α → α → Prop} (wf : well_founded r) (s : set α)
    (h : bounded r s) : α :=
  min wf (set_of fun (x : α) => ∀ (a : α), a ∈ s → r a x) h

protected theorem lt_sup {α : Type u_1} {r : α → α → Prop} (wf : well_founded r) {s : set α}
    (h : bounded r s) {x : α} (hx : x ∈ s) : r x (well_founded.sup wf s h) :=
  min_mem wf (set_of fun (x : α) => ∀ (a : α), a ∈ s → r a x) h x hx

/-- A successor of an element `x` in a well-founded order is a minimal element `y` such that
`x < y` if one exists. Otherwise it is `x` itself. -/
protected def succ {α : Type u_1} {r : α → α → Prop} (wf : well_founded r) (x : α) : α :=
  dite (∃ (y : α), r x y) (fun (h : ∃ (y : α), r x y) => min wf (set_of fun (y : α) => r x y) h)
    fun (h : ¬∃ (y : α), r x y) => x

protected theorem lt_succ {α : Type u_1} {r : α → α → Prop} (wf : well_founded r) {x : α}
    (h : ∃ (y : α), r x y) : r x (well_founded.succ wf x) :=
  sorry

protected theorem lt_succ_iff {α : Type u_1} {r : α → α → Prop} [wo : is_well_order α r] {x : α}
    (h : ∃ (y : α), r x y) (y : α) : r y (well_founded.succ is_well_order.wf x) ↔ r y x ∨ y = x :=
  sorry

end Mathlib


/- Q7 : are the following numbers rational or irrational
(a) sqrt(2)+sqrt(3/2)
(b) 1+sqrt(2)+sqrt(3/2)
(c) 2sqrt(18)-3sqrt(8)
-/

theorem Q7a : M1F.is_irrational (square_root.sqrt_abs 2 + square_root.sqrt_abs (3/2)) := sorry

theorem Q7b : M1F.is_irrational (1+square_root.sqrt_abs 2+square_root.sqrt_abs (3/2)) := sorry

theorem Q7c : exists q:ℚ, (q:ℝ) = 2*square_root.sqrt_abs 18 - 3 * square_root.sqrt_abs 8 := sorry