l3lab/ntp-mathlib huggingface dataset:
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⟩
    

Proof state:
case this.mk.cons.intro.intro.intro
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)
ih :
  ∀ (chain : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) l),
    ∃ w',
      ReducedWord.prod φ w'.toReducedWord = ReducedWord.prod φ { head := 1, toList := l, chain := chain } ∧
        List.map Prod.fst w'.toList = List.map Prod.fst { head := 1, toList := l, chain := chain }.toList ∧
          ∀ u ∈ Option.map Prod.fst (List.head? { head := 1, toList := l, chain := chain }.toList),
            w'.head ∈ toSubgroup A B (-u)
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)
⊢ ∃ w',
    ReducedWord.prod φ w'.toReducedWord = ReducedWord.prod φ { head := 1, toList := a :: l, chain := chain } ∧
      List.map Prod.fst w'.toList = List.map Prod.fst { head := 1, toList := a :: l, chain := chain }.toList ∧
        ∀ u ∈ Option.map Prod.fst (List.head? { head := 1, toList := a :: l, chain := chain }.toList),
          w'.head ∈ toSubgroup A B (-u)

Next tactic:
clear ih
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
    

Proof state:
case this.mk.cons.intro.intro.intro
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)
⊢ ∃ w',
    ReducedWord.prod φ w'.toReducedWord = ReducedWord.prod φ { head := 1, toList := a :: l, chain := chain } ∧
      List.map Prod.fst w'.toList = List.map Prod.fst { head := 1, toList := a :: l, chain := chain }.toList ∧
        ∀ u ∈ Option.map Prod.fst (List.head? { head := 1, toList := a :: l, chain := chain }.toList),
          w'.head ∈ toSubgroup A B (-u)

Next tactic:
refine ⟨(t^(a.1 : ℤ) * of a.2 : HNNExtension G A B φ) • w', ?_, ?_⟩
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', ?_, ?_⟩
    · 

Proof state:
case this.mk.cons.intro.intro.intro.refine_1
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)
⊢ ReducedWord.prod φ ((t ^ ↑a.1 * of a.2) • w').toReducedWord =
    ReducedWord.prod φ { head := 1, toList := a :: l, chain := chain }

Next tactic:
rw [prod_smul, hw'1]
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]
      

Proof state:
case this.mk.cons.intro.intro.intro.refine_1
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)
⊢ t ^ ↑a.1 * of a.2 *
      ReducedWord.prod φ
        { head := 1, toList := l, chain := (_ : List.Chain' (fun a b => a.2 ∈ toSubgroup A B a.1 → a.1 = b.1) l) } =
    ReducedWord.prod φ { head := 1, toList := a :: l, chain := chain }

Next tactic:
simp [ReducedWord.prod]
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
        

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)
⊢ ¬Cancels a.1 (a.2 • w')

Next tactic:
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]
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]
        

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)
⊢ a.2 * w'.head ∈ toSubgroup A B a.1 → ∀ (x : G), ¬List.head? w'.toList = some (-a.1, x)

Next tactic:
intro hS x hx
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
        

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 * w'.head ∈ toSubgroup A B a.1
x : G
hx : List.head? w'.toList = some (-a.1, x)
⊢ False

Next tactic:
have hx' := congr_arg (Option.map Prod.fst) hx
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
        

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 * w'.head ∈ toSubgroup A B a.1
x : G
hx : List.head? w'.toList = some (-a.1, x)
hx' : Option.map Prod.fst (List.head? w'.toList) = Option.map Prod.fst (some (-a.1, x))
⊢ False

Next tactic:
rw [← List.head?_map, hw'2, List.head?_map, Option.map_some'] at hx'
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'
        

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 * w'.head ∈ 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
⊢ False

Next tactic:
have : w'.head ∈ toSubgroup A B a.fst := by
          simpa using hw'3 _ hx'