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
          

Proof state:
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)
hS : a.2 ∈ toSubgroup A B a.1
x : G
hx : List.head? w'.toList = some (-a.1, x)
hx' :
  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) =
    some (-a.1, x).1
this✝ : w'.head ∈ toSubgroup A B a.1
hl : l ≠ []
this : a.1 = (List.head l hl).1
⊢ a.1 = -a.1

Next tactic:
rwa [List.head?_eq_head _ hl, Option.map_some', ← this, Option.some_inj] at hx'