theorem exists_normalWord_prod_eq
    (d : TransversalPair G A B) (w : ReducedWord G A B) :
    ∃ w' : NormalWord d, w'.prod φ = w.prod φ ∧
      w'.toList.map Prod.fst = w.toList.map Prod.fst ∧
      ∀ u ∈ w.toList.head?.map Prod.fst,
      w'.head⁻¹ * w.head ∈ toSubgroup A B (-u) := by
  suffices : ∀ w : ReducedWord G A B,
      w.head = 1 → ∃ w' : NormalWord d, w'.prod φ = w.prod φ ∧
      w'.toList.map Prod.fst = w.toList.map Prod.fst ∧
      ∀ u ∈ w.toList.head?.map Prod.fst,
      w'.head ∈ toSubgroup A B (-u)
  · by_cases hw1 : w.head = 1
    · simp only [hw1, inv_mem_iff, mul_one]
      exact this w hw1
    · rcases this ⟨1, w.toList, w.chain⟩ rfl with ⟨w', hw'⟩
      exact ⟨w.head • w', by
        simpa [ReducedWord.prod, mul_assoc] using hw'⟩
  intro w hw1
  rcases w with ⟨g, l, chain⟩
  dsimp at hw1; subst hw1
  induction l with
  | nil =>
    exact
      ⟨{ head := 1
         toList := []
         mem_set := by simp
         chain := List.chain'_nil }, by simp [prod]⟩
  | cons a l ih =>
    rcases ih (List.chain'_cons'.1 chain).2 with ⟨w', hw'1, hw'2, hw'3⟩
    clear ih
    refine ⟨(t^(a.1 : ℤ) * of a.2 : HNNExtension G A B φ) • w', ?_, ?_⟩
    · rw [prod_smul, hw'1]
      simp [ReducedWord.prod]
    · have : ¬ Cancels a.1 (a.2 • w') := by
        simp only [Cancels, group_smul_head, group_smul_toList, Option.map_eq_some',
          Prod.exists, exists_and_right, exists_eq_right, not_and, not_exists]
        intro hS x hx
        have hx' := congr_arg (Option.map Prod.fst) hx
        rw [← List.head?_map, hw'2, List.head?_map, Option.map_some'] at hx'
        have : w'.head ∈ toSubgroup A B a.fst := by
          simpa using hw'3 _ hx'
        rw [mul_mem_cancel_right this] at hS
        have : a.fst = -a.fst := by
          have hl : l ≠ [] := by rintro rfl; simp_all
          have : a.fst = (l.head hl).fst := (List.chain'_cons'.1 chain).1 (l.head hl)
            (List.head?_eq_head _ _) hS
          rwa [List.head?_eq_head _ hl, Option.map_some', ← this, Option.some_inj] at hx'
        simp at this
      erw [List.map_cons, mul_smul, of_smul_eq_smul, NormalWord.group_smul_def,
        t_pow_smul_eq_unitsSMul, unitsSMul, dif_neg this, ← hw'2]
      

Proof state:
case this.mk.cons.intro.intro.intro.refine_2
G : Type u_1
inst✝² : Group G
A B : Subgroup G
φ : ↥A ≃* ↥B
H : Type u_2
inst✝¹ : Group H
M : Type u_3
inst✝ : Monoid M
d : TransversalPair G A B
w : ReducedWord G A B
a : ℤˣ × G
l : List (ℤˣ × G)
chain : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) (a :: l)
w' : NormalWord d
hw'1 :
  ReducedWord.prod φ w'.toReducedWord =
    ReducedWord.prod φ
      { head := 1, toList := l, chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) l) }
hw'2 :
  List.map Prod.fst w'.toList =
    List.map Prod.fst
      { head := 1, toList := l, chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) l) }.toList
hw'3 :
  ∀
    u ∈
      Option.map Prod.fst
        (List.head?
          { head := 1, toList := l,
              chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) l) }.toList),
    w'.head ∈ toSubgroup A B (-u)
this : ¬Cancels a.1 (a.2 • w')
⊢ List.map Prod.fst
        (let g' :=
            unitsSMulGroup φ d a.1
              {
                    toReducedWord :=
                      { head := a.2 * w'.head, toList := w'.toList,
                        chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                    mem_set :=
                      (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head;
          cons (↑g'.1) a.1
            ((↑g'.2 *
                {
                        toReducedWord :=
                          { head := a.2 * w'.head, toList := w'.toList,
                            chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                        mem_set :=
                          (_ :
                            ∀ (u : ℤˣ) (g : G),
                              (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
              {
                toReducedWord :=
                  { head := a.2 * w'.head, toList := w'.toList,
                    chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                mem_set := (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) })
            (_ :
              ↑(unitsSMulGroup φ d a.1
                          {
                                toReducedWord :=
                                  { head := a.2 * w'.head, toList := w'.toList,
                                    chain :=
                                      (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                mem_set :=
                                  (_ :
                                    ∀ (u : ℤˣ) (g : G),
                                      (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                    {
                            toReducedWord :=
                              { head := a.2 * w'.head, toList := w'.toList,
                                chain :=
                                  (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                            mem_set :=
                              (_ :
                                ∀ (u : ℤˣ) (g : G),
                                  (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹ *
                  {
                        toReducedWord :=
                          { head := a.2 * w'.head, toList := w'.toList,
                            chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                        mem_set :=
                          (_ :
                            ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head ∈
                TransversalPair.set d a.1)
            (_ :
              ∀
                u' ∈
                  Option.map Prod.fst
                    (List.head?
                      ((↑(unitsSMulGroup φ d a.1
                                  {
                                        toReducedWord :=
                                          { head := a.2 * w'.head, toList := w'.toList,
                                            chain :=
                                              (_ :
                                                List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1)
                                                  w'.toList) },
                                        mem_set :=
                                          (_ :
                                            ∀ (u : ℤˣ) (g : G),
                                              (u, g) ∈ w'.toList →
                                                g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                            {
                                    toReducedWord :=
                                      { head := a.2 * w'.head, toList := w'.toList,
                                        chain :=
                                          (_ :
                                            List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                    mem_set :=
                                      (_ :
                                        ∀ (u : ℤˣ) (g : G),
                                          (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
                          {
                            toReducedWord :=
                              { head := a.2 * w'.head, toList := w'.toList,
                                chain :=
                                  (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                            mem_set :=
                              (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }).toList),
                ((↑(unitsSMulGroup φ d a.1
                                {
                                      toReducedWord :=
                                        { head := a.2 * w'.head, toList := w'.toList,
                                          chain :=
                                            (_ :
                                              List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1)
                                                w'.toList) },
                                      mem_set :=
                                        (_ :
                                          ∀ (u : ℤˣ) (g : G),
                                            (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                          {
                                  toReducedWord :=
                                    { head := a.2 * w'.head, toList := w'.toList,
                                      chain :=
                                        (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                  mem_set :=
                                    (_ :
                                      ∀ (u : ℤˣ) (g : G),
                                        (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
                        {
                          toReducedWord :=
                            { head := a.2 * w'.head, toList := w'.toList,
                              chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                          mem_set :=
                            (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }).head ∈
                    toSubgroup A B a.1 →
                  a.1 = u')).toList =
      a.1 :: List.map Prod.fst w'.toList ∧
    ∀ u ∈ Option.map Prod.fst (List.head? { head := 1, toList := a :: l, chain := chain }.toList),
      (let g' :=
            unitsSMulGroup φ d a.1
              {
                    toReducedWord :=
                      { head := a.2 * w'.head, toList := w'.toList,
                        chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                    mem_set :=
                      (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head;
          cons (↑g'.1) a.1
            ((↑g'.2 *
                {
                        toReducedWord :=
                          { head := a.2 * w'.head, toList := w'.toList,
                            chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                        mem_set :=
                          (_ :
                            ∀ (u : ℤˣ) (g : G),
                              (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
              {
                toReducedWord :=
                  { head := a.2 * w'.head, toList := w'.toList,
                    chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                mem_set := (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) })
            (_ :
              ↑(unitsSMulGroup φ d a.1
                          {
                                toReducedWord :=
                                  { head := a.2 * w'.head, toList := w'.toList,
                                    chain :=
                                      (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                mem_set :=
                                  (_ :
                                    ∀ (u : ℤˣ) (g : G),
                                      (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                    {
                            toReducedWord :=
                              { head := a.2 * w'.head, toList := w'.toList,
                                chain :=
                                  (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                            mem_set :=
                              (_ :
                                ∀ (u : ℤˣ) (g : G),
                                  (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹ *
                  {
                        toReducedWord :=
                          { head := a.2 * w'.head, toList := w'.toList,
                            chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                        mem_set :=
                          (_ :
                            ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head ∈
                TransversalPair.set d a.1)
            (_ :
              ∀
                u' ∈
                  Option.map Prod.fst
                    (List.head?
                      ((↑(unitsSMulGroup φ d a.1
                                  {
                                        toReducedWord :=
                                          { head := a.2 * w'.head, toList := w'.toList,
                                            chain :=
                                              (_ :
                                                List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1)
                                                  w'.toList) },
                                        mem_set :=
                                          (_ :
                                            ∀ (u : ℤˣ) (g : G),
                                              (u, g) ∈ w'.toList →
                                                g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                            {
                                    toReducedWord :=
                                      { head := a.2 * w'.head, toList := w'.toList,
                                        chain :=
                                          (_ :
                                            List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                    mem_set :=
                                      (_ :
                                        ∀ (u : ℤˣ) (g : G),
                                          (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
                          {
                            toReducedWord :=
                              { head := a.2 * w'.head, toList := w'.toList,
                                chain :=
                                  (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                            mem_set :=
                              (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }).toList),
                ((↑(unitsSMulGroup φ d a.1
                                {
                                      toReducedWord :=
                                        { head := a.2 * w'.head, toList := w'.toList,
                                          chain :=
                                            (_ :
                                              List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1)
                                                w'.toList) },
                                      mem_set :=
                                        (_ :
                                          ∀ (u : ℤˣ) (g : G),
                                            (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head).2 *
                          {
                                  toReducedWord :=
                                    { head := a.2 * w'.head, toList := w'.toList,
                                      chain :=
                                        (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                                  mem_set :=
                                    (_ :
                                      ∀ (u : ℤˣ) (g : G),
                                        (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }.toReducedWord.head⁻¹) •
                        {
                          toReducedWord :=
                            { head := a.2 * w'.head, toList := w'.toList,
                              chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) w'.toList) },
                          mem_set :=
                            (_ : ∀ (u : ℤˣ) (g : G), (u, g) ∈ w'.toList → g ∈ TransversalPair.set d u) }).head ∈
                    toSubgroup A B a.1 →
                  a.1 = u')).head ∈
        toSubgroup A B (-u)

Next tactic:
simp [mul_assoc, unitsSMulGroup, (d.compl _).coe_equiv_snd_eq_one_iff_mem]