/-- If `α` is an infinite type, then `α × α` and `α` have the same cardinality. -/
theorem mul_eq_self {c : Cardinal} (h : ℵ₀ ≤ c) : c * c = c := by
  refine' le_antisymm _ (by simpa only [mul_one] using mul_le_mul_left' (one_le_aleph0.trans h) c)
  -- the only nontrivial part is `c * c ≤ c`. We prove it inductively.
  refine' Acc.recOn (Cardinal.lt_wf.apply c) (fun c _ => Quotient.inductionOn c fun α IH ol => _) h
  -- consider the minimal well-order `r` on `α` (a type with cardinality `c`).
  rcases ord_eq α with ⟨r, wo, e⟩
  skip
  letI := linearOrderOfSTO r
  haveI : IsWellOrder α (· < ·) := wo
  -- Define an order `s` on `α × α` by writing `(a, b) < (c, d)` if `max a b < max c d`, or
  -- the max are equal and `a < c`, or the max are equal and `a = c` and `b < d`.
  let g : α × α → α := fun p => max p.1 p.2
  let f : α × α ↪ Ordinal × α × α :=
    ⟨fun p : α × α => (typein (· < ·) (g p), p), fun p q => congr_arg Prod.snd⟩
  let s := f ⁻¹'o Prod.Lex (· < ·) (Prod.Lex (· < ·) (· < ·))
  -- this is a well order on `α × α`.
  haveI : IsWellOrder _ s := (RelEmbedding.preimage _ _).isWellOrder
  /- it suffices to show that this well order is smaller than `r`
       if it were larger, then `r` would be a strict prefix of `s`. It would be contained in
      `β × β` for some `β` of cardinality `< c`. By the inductive assumption, this set has the
      same cardinality as `β` (or it is finite if `β` is finite), so it is `< c`, which is a
      contradiction. -/
  suffices type s ≤ type r by exact card_le_card this
  refine' le_of_forall_lt fun o h => _
  rcases typein_surj s h with ⟨p, rfl⟩
  rw [← e, lt_ord]
  refine'
    lt_of_le_of_lt (_ : _ ≤ card (succ (typein (· < ·) (g p))) * card (succ (typein (· < ·) (g p))))
      _
  · have : { q | s q p } ⊆ insert (g p) { x | x < g p } ×ˢ insert (g p) { x | x < g p } := by
      intro q h
      simp only [Preimage, ge_iff_le, Embedding.coeFn_mk, Prod.lex_def, typein_lt_typein,
        typein_inj, mem_setOf_eq] at h
      exact max_le_iff.1 (le_iff_lt_or_eq.2 <| h.imp_right And.left)
    suffices H : (insert (g p) { x | r x (g p) } : Set α) ≃ Sum { x | r x (g p) } PUnit
    · exact
        ⟨(Set.embeddingOfSubset _ _ this).trans
            ((Equiv.Set.prod _ _).trans (H.prodCongr H)).toEmbedding⟩
    

Proof state:
case H
c✝ : Cardinal.{u_1}
h✝ : ℵ₀ ≤ c✝
c : Cardinal.{u_1}
x✝ : ∀ y < c, Acc (fun x x_1 => x < x_1) y
α : Type u_1
IH : ∀ y < ⟦α⟧, ℵ₀ ≤ y → y * y ≤ y
ol : ℵ₀ ≤ ⟦α⟧
r : α → α → Prop
wo : IsWellOrder α r
e : ord #α = type r
this✝² : LinearOrder α := linearOrderOfSTO r
this✝¹ : IsWellOrder α fun x x_1 => x < x_1
g : α × α → α := fun p => max p.1 p.2
f : α × α ↪ Ordinal.{u_1} × α × α :=
  { toFun := fun p => (typein (fun x x_1 => x < x_1) (g p), p),
    inj' :=
      (_ :
        ∀ (p q : α × α),
          (fun p => (typein (fun x x_1 => x < x_1) (g p), p)) p =
              (fun p => (typein (fun x x_1 => x < x_1) (g p), p)) q →
            ((fun p => (typein (fun x x_1 => x < x_1) (g p), p)) p).2 =
              ((fun p => (typein (fun x x_1 => x < x_1) (g p), p)) q).2) }
s : α × α → α × α → Prop :=
  ⇑f ⁻¹'o Prod.Lex (fun x x_1 => x < x_1) (Prod.Lex (fun x x_1 => x < x_1) fun x x_1 => x < x_1)
this✝ : IsWellOrder (α × α) s
p : α × α
h : typein s p < type s
this : {q | s q p} ⊆ insert (g p) {x | x < g p} ×ˢ insert (g p) {x | x < g p}
⊢ ↑(insert (g p) {x | r x (g p)}) ≃ ↑{x | r x (g p)} ⊕ PUnit.{u_1 + 1}

Next tactic:
refine' (Equiv.Set.insert _).trans ((Equiv.refl _).sumCongr punitEquivPUnit)