-- ArkLib/Data/FieldTheory/BinaryField/Tower/Impl.lean

import ArkLib.Data.Classes.DCast

import ArkLib.Data.FieldTheory.BinaryField.Tower.Basic

namespace ConcreteBinaryTower

open Polynomial

def ConcreteBTField : ℕ → Type := fun k => BitVec (2 ^ k)

section BitVecDCast

instance BitVec.instDCast : DCast Nat BitVec where
  dcast h := BitVec.cast h
  dcast_id := by admit /- proof elided -/

end BitVecDCast

section ConversionUtils

def fromNat {k : ℕ} (n : Nat) : ConcreteBTField k :=
  BitVec.ofNat (2 ^ k) n

instance ConcreteBTField.instDCast_local : DCast ℕ ConcreteBTField where
  dcast h_k_eq term_k1 := BitVec.cast (congrArg (fun n => 2 ^ n) h_k_eq) term_k1
  dcast_id := by admit /- proof elided -/

end ConversionUtils

section NumericLemmas

end NumericLemmas

section FieldOperationsAndInstances

def zero {k : ℕ} : ConcreteBTField k := BitVec.zero (2 ^ k)

def one {k : ℕ} : ConcreteBTField k := 1#(2 ^ k)

def add {k : ℕ} (x y : ConcreteBTField k) : ConcreteBTField k := BitVec.xor x y

def neg {k : ℕ} (x : ConcreteBTField k) : ConcreteBTField k := x

def split {k : ℕ} (h : k > 0) (x : ConcreteBTField k) :
    ConcreteBTField (k - 1) × ConcreteBTField (k - 1) :=
  let lo_bits : BitVec (2 ^ (k - 1) - 1 - 0 + 1) :=
    BitVec.extractLsb (hi := 2 ^ (k - 1) - 1) (lo := 0) x
  let hi_bits : BitVec (2 ^ k - 1 - 2 ^ (k - 1) + 1) :=
    BitVec.extractLsb (hi := 2 ^ k - 1) (lo := 2 ^ (k - 1)) x
  have h_lo : 2 ^ (k - 1) - 1 - 0 + 1 = 2 ^ (k - 1) := by admit /- proof elided -/

def join {k : ℕ} (h_pos : k > 0) (hi lo : ConcreteBTField (k - 1)) : ConcreteBTField k :=

structure ConcreteBTFAddCommGroupProps (k : ℕ) where
  add_assoc : ∀ a b c : ConcreteBTField k, (a + b) + c = a + (b + c) := add_assoc
  add_comm : ∀ a b : ConcreteBTField k, a + b = b + a := add_comm
  add_zero : ∀ a : ConcreteBTField k, a + zero = a := add_zero
  zero_add : ∀ a : ConcreteBTField k, zero + a = a := zero_add
  add_neg : ∀ a : ConcreteBTField k, a + (neg a) = zero := neg_add_cancel

def mkAddCommGroupInstance {k : ℕ} : AddCommGroup (ConcreteBTField k) := {
  zero := zero
  neg := neg
  sub := fun x y => add x y
  add_assoc := add_assoc
  add_comm := add_comm
  zero_add := zero_add
  add_zero := add_zero
  nsmul := fun n x => if n % 2 = (0 : ℕ) then zero else x
  zsmul := fun (n : ℤ) x => if n % 2 = 0 then zero else x  
  neg_add_cancel := neg_add_cancel
  nsmul_succ := nsmul_succ
  zsmul_succ' := fun n a => zsmul_succ n a
  add := add
  zsmul_neg' := zsmul_neg' (k := k)
}

def Z (k : ℕ) : ConcreteBTField k :=
  if h_k : k = 0 then one
  else
    《 one (k:=k-1), zero (k:=k-1) 》

def equivProd {k : ℕ} (h_k_pos : k > 0) :
  ConcreteBTField k ≃ ConcreteBTField (k - 1) × ConcreteBTField (k - 1) where
  toFun := split h_k_pos
  invFun := fun (hi, lo) => 《 hi, lo 》
  left_inv := fun x => Eq.symm (join_of_split h_k_pos x _ _ rfl)
  right_inv := fun ⟨hi, lo⟩ => Eq.symm (split_of_join h_k_pos _ hi lo rfl)

def concrete_mul {k : ℕ} (a b : ConcreteBTField k) : ConcreteBTField k :=
  if h_k_zero : k = 0 then
    if a = zero then zero
    else if b = zero then zero
    else if a = one then b
    else if b = one then a
    else zero 
  else
    have h_k_gt_0 : k > 0 := by admit /- proof elided -/

def concrete_inv {k : ℕ} (a : ConcreteBTField k) : ConcreteBTField k :=
  if h_k_zero : k = 0 then
    if a = 0 then 0 else 1
  else
    if h_a_zero : a = 0 then 0
    else if h_a_one : a = 1 then 1
    else
      let h_k_gt_0 : k > 0 := Nat.zero_lt_of_ne_zero h_k_zero
      let (a_hi, a_lo) := split (k:=k) (h:=h_k_gt_0) a
      let prevZ := Z (k - 1)
      let a_lo_next := a_lo + concrete_mul a_hi prevZ
      let delta := concrete_mul a_lo a_lo_next + concrete_mul a_hi a_hi
      let delta_inverse := concrete_inv delta
      let out_hi := concrete_mul delta_inverse a_hi
      let out_lo := concrete_mul delta_inverse a_lo_next
      let res := 《 out_hi, out_lo 》
      res

section FieldLemmasOfLevel0

end FieldLemmasOfLevel0

section NumericCasting

def natCast {k : ℕ} (n : ℕ) : ConcreteBTField k := if n % 2 = 0 then zero else one

def natCast_zero {k : ℕ} : natCast (k:=k) 0 = zero :=

def natCast_succ {k : ℕ} (n : ℕ) : natCast (k:=k) (n + 1) = natCast (k:=k) n + 1 :=

def intCast {k : ℕ} (n : ℤ) : ConcreteBTField k := if n % 2 = 0 then zero else one

def intCast_ofNat {k : ℕ} (n : ℕ) : intCast (k:=k) (n : ℤ) = natCast n :=

def intCast_negSucc {k : ℕ} (n : ℕ) : intCast (k:=k) (Int.negSucc n)
  = - (↑(n + 1) : ConcreteBTField k) :=

end NumericCasting

structure ConcreteBTFRingProps (k : ℕ) extends (ConcreteBTFAddCommGroupProps k) where
  
  mul_eq : ∀ (a b : ConcreteBTField k) (h_k : k > 0)
    {a₁ a₀ b₁ b₀ : ConcreteBTField (k - 1)}
    (_h_a : (a₁, a₀) = split h_k a) (_h_b : (b₁, b₀) = split h_k b),
    concrete_mul a b =
      《 concrete_mul a₀ b₁ + concrete_mul b₀ a₁ + concrete_mul (concrete_mul a₁ b₁) (Z (k - 1)),
      concrete_mul a₀ b₀ + concrete_mul a₁ b₁ 》

  
  zero_mul : ∀ a : ConcreteBTField k, concrete_mul zero a = zero
  zero_mul' : ∀ a : ConcreteBTField k, concrete_mul 0 a = 0
  mul_zero : ∀ a : ConcreteBTField k, concrete_mul a zero = zero
  mul_zero' : ∀ a : ConcreteBTField k, concrete_mul a 0 = 0
  one_mul : ∀ a : ConcreteBTField k, concrete_mul one a = a
  mul_one : ∀ a : ConcreteBTField k, concrete_mul a one = a

  
  mul_assoc : ∀ a b c : ConcreteBTField k, concrete_mul (concrete_mul a b) c
    = concrete_mul a (concrete_mul b c)
  mul_left_distrib : ∀ a b c : ConcreteBTField k, concrete_mul a (b + c)
    = concrete_mul a b + concrete_mul a c
  mul_right_distrib : ∀ a b c : ConcreteBTField k, concrete_mul (a + b) c
    = concrete_mul a c + concrete_mul b c

structure ConcreteBTFDivisionRingProps (k : ℕ) extends (ConcreteBTFRingProps k) where
  
  mul_inv_cancel : ∀ a : ConcreteBTField k, a ≠ zero → concrete_mul a (concrete_inv a) = one

structure ConcreteBTFieldProps (k : ℕ) extends (ConcreteBTFDivisionRingProps k) where
  
  mul_comm : ∀ a b : ConcreteBTField k, concrete_mul a b = concrete_mul b a

def mkRingInstance {k : ℕ} (props : ConcreteBTFieldProps k) : Ring (ConcreteBTField k) where
  toAddCommGroup := mkAddCommGroupInstance
  toOne := inferInstance
  mul := concrete_mul
  mul_assoc := props.mul_assoc
  one_mul := props.one_mul
  mul_one := props.mul_one
  left_distrib := props.mul_left_distrib
  right_distrib := props.mul_right_distrib
  zero_mul := props.zero_mul
  mul_zero := props.mul_zero

  natCast n := natCast n
  natCast_zero := natCast_zero
  natCast_succ n := natCast_succ n
  intCast n := intCast n
  intCast_ofNat n := intCast_ofNat n
  intCast_negSucc n := intCast_negSucc n

def mkDivisionRingInstance {k : ℕ} (props : ConcreteBTFieldProps k)
    : DivisionRing (ConcreteBTField k) where
  toRing := mkRingInstance (k:=k) props
  inv := concrete_inv
  exists_pair_ne := concrete_exists_pair_ne (k := k)
  mul_inv_cancel := props.mul_inv_cancel
  inv_zero := concrete_inv_zero
  qsmul := (Rat.castRec · * ·)
  nnqsmul := (NNRat.castRec · * ·)

def mkFieldInstance {k : ℕ} (props : ConcreteBTFieldProps k) : Field (ConcreteBTField k) where
  toDivisionRing := mkDivisionRingInstance (k:=k) props
  mul_comm := props.mul_comm

structure ConcreteBTFStepResult (k : ℕ) extends (ConcreteBTFieldProps k) where
  instFintype : Fintype (ConcreteBTField k)
  fieldFintypeCard : Fintype.card (ConcreteBTField k) = 2^(2^k)
  
  sumZeroIffEq : ∀ (x y : ConcreteBTField k), x + y = 0 ↔ x = y
  traceMapEvalAtRootsIs1 :
    letI := mkFieldInstance (k:=k) (props:=toConcreteBTFieldProps)
    TraceMapProperty (ConcreteBTField k) (u:=Z k) k
  instIrreduciblePoly :
    letI := mkFieldInstance (k:=k) (props:=toConcreteBTFieldProps)
    (Irreducible (p := (definingPoly (s:=(Z k)))))

end FieldOperationsAndInstances

section BTFieldPropsOneLevelLiftingLemmas

variable {k : ℕ} {h_k : k > 0}

end BTFieldPropsOneLevelLiftingLemmas

section TowerFieldsConstruction

def liftBTFieldProps (k : ℕ) (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  ConcreteBTFieldProps (k + 1) := {
    zero_mul := concrete_zero_mul (prevBTFResult.toConcreteBTFieldProps),
    zero_mul' := fun a => by admit /- proof elided -/

def liftConcreteBTField (k : ℕ) (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  Field (ConcreteBTField (k + 1)) :=

def concreteCanonicalEmbedding (k : ℕ)
    (prevBTFieldProps : ConcreteBTFieldProps (k := (k)))
    (curBTFieldProps : ConcreteBTFieldProps (k := (k + 1))) :
  letI := mkFieldInstance prevBTFieldProps
  letI := mkFieldInstance curBTFieldProps
  ConcreteBTField k →+* ConcreteBTField (k + 1) :=

instance instAlgebraLiftConcreteBTField (k : ℕ)
  (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  letI := mkFieldInstance (prevBTFResult.toConcreteBTFieldProps)
  letI := liftConcreteBTField (k:=k) prevBTFResult
  Algebra (ConcreteBTField k) (ConcreteBTField (k + 1)) :=
  letI := mkFieldInstance (prevBTFResult.toConcreteBTFieldProps)
  letI := liftConcreteBTField (k:=k) prevBTFResult
  RingHom.toAlgebra (R:=ConcreteBTField k) (S:=ConcreteBTField (k + 1))
    (i:=(concreteCanonicalEmbedding (k:=k)
      (prevBTFieldProps:=prevBTFResult.toConcreteBTFieldProps)
      (curBTFieldProps:=liftBTFieldProps (k:=k) (prevBTFResult:=prevBTFResult))))

def getBTFResult (k : ℕ) : ConcreteBTFStepResult k :=
  match k with
  | 0 =>
    let base : ConcreteBTFieldProps 0 := {
      mul_eq := fun a b h_k _ _ _ _ _ _ => by admit /- proof elided -/
| c1_one
        · 
          rw [c1_zero] at h_mul
          
          simp at h_mul
        · 
          rcases c2_cases with c2_zero | c2_one
          · 
            rw [c2_zero] at h_mul
            
            simp at h_mul
          · 
            
            exact ⟨c1_one, c2_one⟩
      
      have specialElement_eq_zero : specialElement = 0 := by admit /- proof elided -/

end TowerFieldsConstruction

section ConcreteBTFieldAlgebraConstruction

def canonicalAlgMap (k : ℕ) := concreteCanonicalEmbedding (k:=k)
  (prevBTFieldProps:= ((getBTFResult k).toConcreteBTFieldProps))
  (curBTFieldProps:= ((getBTFResult (k + 1)).toConcreteBTFieldProps))

def concreteTowerAlgebraMap (l r : ℕ) (h_le : l ≤ r) :
    ConcreteBTField l →+* ConcreteBTField r :=

instance instAlgebraTowerConcreteBTF : AlgebraTower (ConcreteBTField) where
  algebraMap := concreteTowerAlgebraMap
  commutes' := by admit /- proof elided -/

def ConcreteBTFieldAlgebra {l r : ℕ} (h_le : l ≤ r) :
    Algebra (ConcreteBTField l) (ConcreteBTField r) := instAlgebraTowerConcreteBTF.toAlgebra h_le

def join_via_add_smul (k : ℕ) (h_pos : k > 0) (hi_btf lo_btf : ConcreteBTField (k - 1)) :
    ConcreteBTField k :=

end ConcreteBTFieldAlgebraConstruction

noncomputable section ConcreteMultilinearBasis

open Module

def basisSucc (k : ℕ) : Basis (Fin 2) (ConcreteBTField k) (ConcreteBTField (k + 1)) :=

def powerBasisSucc (k : ℕ) :
    PowerBasis (ConcreteBTField k) (ConcreteBTField (k + 1)) :=

end ConcreteMultilinearBasis

section TowerEquivalence

open BinaryTower

noncomputable def towerEquiv_zero : RingEquiv (R:=GF(2)) (S:=ConcreteBTField 0) :=  {
  toFun := fun x => if x = 0 then 0 else 1,
  invFun := fun x => if x = 0 then 0 else 1,
  left_inv := fun x => by admit /- proof elided -/

noncomputable def towerRingEquiv0 : BTField 0 ≃+* ConcreteBTField 0 :=

noncomputable def towerRingEquivFromConcrete0 : ConcreteBTField 0 ≃+* BTField 0 :=

noncomputable def towerRingHomForwardMap (k : ℕ) : ConcreteBTField k → BTField k :=

noncomputable def towerRingHomBackwardMap (k : ℕ) : BTField k → ConcreteBTField k :=

structure TowerEquivResult (k : ℕ) where
  ringEquiv : ConcreteBTField k ≃+* BTField k
  ringEquivForwardMapEq : ringEquiv = towerRingHomForwardMap k

noncomputable def towerEquiv (n : ℕ) : TowerEquivResult n :=

-- Repository definitions used:
content: notation : 10 "GF(" term : 10 ")" => GaloisField term 1

content: class DCast (α : Sort*) (β : α → Sort*) where
  dcast : ∀ {a a' : α}, a = a' → β a → β a'
  dcast_id : ∀ {a : α}, dcast (Eq.refl a) = id

content: @[simp]
def BTField (k : ℕ) := (BinaryTowerAux k).1

content: def BinaryTowerAux (k : ℕ) : (Σ' (F : Type 0), BinaryTowerResult F k) :=
  match k with
  | 0 => 
    let curBTField := GF(2)
    let newList : List.Vector (GF(2)) 1 := List.Vector.cons (1 : GF(2)) List.Vector.nil
    let specialElement : GF(2) := newList.1.headI
    let firstElementOfVecIsSpecialElement : newList.1.headI = specialElement := rfl
    let specialElementIs1 : specialElement = 1 := by admit /- proof elided -/

content: structure BinaryTowerInductiveStepResult (k : ℕ) (prevBTField : Type _)
  (prevBTResult : BinaryTowerResult prevBTField k) [instPrevBTFieldIsField : Field prevBTField]
  (prevPoly : Polynomial prevBTField) (F : Type _) where
  binaryTowerResult : BinaryTowerResult F (k+1)
  eq_adjoin : F = AdjoinRoot prevPoly
  u_is_root : Eq.mp (eq_adjoin) binaryTowerResult.specialElement = AdjoinRoot.root prevPoly
  eval_defining_poly_at_root : Eq.mp (eq_adjoin) binaryTowerResult.specialElement^2 +
    Eq.mp (eq_adjoin) binaryTowerResult.specialElement * (of prevPoly) prevBTResult.specialElement
    + 1 = 0

content: structure BinaryTowerResult (F : Type _) (k : ℕ) where
  vec : (List.Vector F (k + 1))
  instField : (Field F)
  instFintype : Fintype F
  specialElement : F
  specialElementNeZero : NeZero specialElement
  firstElementOfVecIsSpecialElement [Inhabited F] : vec.1.headI = specialElement
  instIrreduciblePoly : (Irreducible (p := (definingPoly specialElement)))
  sumZeroIffEq : ∀ (x y : F), x + y = 0 ↔ x = y
  fieldFintypeCard : Fintype.card F = 2^(2^k)
  traceMapEvalAtRootsIs1 : TraceMapProperty F specialElement k

content: @[simp]
def sumZeroIffEq (k : ℕ) : ∀ (x y : BTField k),
  x + y = 0 ↔ x = y := (BinaryTowerAux k).2.sumZeroIffEq

content: @[simp]
instance Inhabited (k : ℕ) : Inhabited (BTField k) where
  default := (0 : BTField k)

content: structure TraceMapProperty (F : Type*) [Field F] (u : F) (k : ℕ) : Prop where
  element_trace : ∑ i ∈ Finset.range (2 ^ k), u ^ (2 ^ i) = 1
  inverse_trace : ∑ i ∈ Finset.range (2 ^ k), (u⁻¹) ^ (2 ^ i) = 1

content: noncomputable def definingPoly {F : Type*} [instField : Field F] (s : F)
  := X ^ 2 + C s * X + 1

content: def binary_tower_inductive_step
  (k : Nat)
  (prevBTField : Type _) [Field prevBTField]
  (prevBTResult : BinaryTowerResult prevBTField k)
: Σ' (F : Type _), BinaryTowerInductiveStepResult (k:=k) (prevBTField:=prevBTField)
  (prevBTResult:=prevBTResult) (prevPoly:=definingPoly (F:=prevBTField)
    (instField:=prevBTResult.instField) (s:=prevBTResult.specialElement)) (F:=F)
  (instPrevBTFieldIsField:=prevBTResult.instField) :=

content: def AlgebraTowerEquiv.symm (e : AlgebraTowerEquiv A B) : AlgebraTowerEquiv B A where
  toRingEquiv := fun i => (e.toRingEquiv i).symm
  commutesLeft' := fun i j h r => by admit /- proof elided -/

content: structure AlgebraTowerEquiv (A : ι → Type*) [∀ i, CommSemiring (A i)] [a : AlgebraTower A]
  (B : ι → Type*) [∀ i, CommSemiring (B i)] [b : AlgebraTower B]
  where
    toRingEquiv : ∀ i, (A i ≃+* B i)
    commutesLeft' : ∀ (i j : ι) (h : i ≤ j) (r : A i),
      (b.algebraMap (i:=i) (j:=j) (h:=h)) ((toRingEquiv i) r) =
      (toRingEquiv j) (a.algebraMap (i:=i) (j:=j) (h:=h) r)

content: structure SpecialElementRelation {F_prev : Type*} [Field F_prev] (t1 : F_prev)
  {F_cur : Type*} [Field F_cur] (u : F_cur) [Algebra F_prev F_cur] : Prop where
    sum_inv_eq : u + u⁻¹ = algebraMap F_prev F_cur t1
    h_u_square : u^2 = u * (algebraMap F_prev F_cur t1) + 1

content: instance irreducible_quadratic_defining_poly_of_traceMap_eq_1
  {F : Type*} [Field F] [Fintype F] [CharP F 2] (s : F) [NeZero s] (k : ℕ)
  (trace_map_prop : TraceMapProperty F s k)
  (fintypeCard : Fintype.card F = 2 ^ (2 ^ k))
  : Irreducible (definingPoly s) :=

content: instance charP_eq_2_of_add_self_eq_zero {F : Type*} [Field F]
    (sumZeroIffEq : ∀ (x y : F), x + y = 0 ↔ x = y) : CharP F 2 :=
  have h_two : (2 : (F)) = 0 := by admit /- proof elided -/

content: def coeff.{u} {F : Type u} [Semiring F] (f : F[X][Y]) (i j : ℕ) : F := (f.coeff j).coeff i

content: instance GF_2_fintype : Fintype (GF(2)) := Fintype.ofFinite (GF(2))

content: def join_via_add_smul {k : ℕ} (h_pos : k > 0) (hi_btf lo_btf : BTField (k - 1)) :
    BTField k :=

content: def binaryAlgebraTower {l r : ℕ} (h_le : l ≤ r) : Algebra (BTField l) (BTField r) :=

content: @[simp]
def AlgebraTower.toAlgebra {i j : ι} (h : i ≤ j) : Algebra (A i) (A j) :=
  (AlgebraTower.algebraMap (i:=i) (j:=j) (h:=h)).toAlgebra

content: @[simp]
def Z (k : ℕ) : BTField k := (BinaryTowerAux k).snd.specialElement 

content: @[simp]
instance AlgebraTower.toIsScalarTower (a : AlgebraTower C) {i j k : ι}
    (h1 : i ≤ j) (h2 : j ≤ k) :
    letI : Algebra (C i) (C j) :=

content: def split (k : ℕ) (h_k : k > 0) (x : BTField k) : BTField (k-1) × BTField (k-1) :=

content: def powerBasisSucc (k : ℕ) :
    PowerBasis (BTField k) (BTField (k+1)) :=

content: def BTField_succ_alg_equiv_adjoinRoot (k : ℕ) :
  AdjoinRoot (poly k) ≃ₐ[BTField k] BTField (k + 1) :=

content: @[simp]
def poly (k : ℕ) : Polynomial (BTField k) := definingPoly (s:=(Z k))

content: @[simp]
instance CommRing (k : ℕ) : CommRing (BTField k) := Field.toCommRing

content: def towerAlgebraMap (l r : ℕ) (h_le : l ≤ r) : BTField l →+* BTField r :=

content: def canonicalEmbedding (k : ℕ) : BTField k →+* BTField (k+1) :=
  AdjoinRoot.of (poly k)

content: instance (priority := 1000) algebra_adjacent_tower (l : ℕ) :
  Algebra (BTField l) (BTField (l+1)) :=

content: instance polyMonic (n : ℕ) : Monic (poly n) := definingPoly_is_monic (Z n)

-- Repository lemmas used:
content: theorem one_le_two_pow_n (n : ℕ) : 1 ≤ 2 ^ n

content: @[simp]
theorem dcast_eq : dcast (Eq.refl a) b = b

content: theorem one_le_sub_consecutive_two_pow (n : ℕ): 1 ≤ 2^(n+1) - 2^n

content: theorem dcast_eq_root_cast (h : a = a') : dcast h b = _root_.cast (congrArg β h) b

content: theorem dcast_symm (ha : a = a') (hb : dcast ha b = b') : dcast (ha.symm) b' = b

content: theorem dcast_eq_dcast_iff (h : a = a'') (h' : a' = a'') :
    dcast h b = dcast h' b' ↔ b = dcast (h'.trans h.symm) b'

content: lemma join_via_add_smul_zero {k : ℕ} (h_pos : k > 0) :
  ⋘ 0, 0 ⋙ = 0

content: lemma algebraMap_eq_zero_x {i j : ℕ} (h_le : i < j) (x : BTField i) :
    letI instAlgebra

content: lemma algebraMap_succ_eq_zero_x {k : ℕ} (h_pos : k > 0) (x : BTField (k - 1)) :
  letI instAlgebra

content: lemma split_algebraMap_eq_zero_x {k : ℕ} (h_pos : k > 0) (x : BTField (k - 1)) :
  letI instAlgebra

content: lemma towerAlgebraMap_succ_1 (k : ℕ) :
  towerAlgebraMap (l:=k) (r:=k+1) (h_le:=by omega) = canonicalEmbedding k

content: lemma towerAlgebraMap_id (k : ℕ) : towerAlgebraMap (h_le:=by omega) = RingHom.id (BTField k)

content: theorem eq_join_via_add_smul_eq_iff_split (k : ℕ) (h_pos : k > 0)
    (x : BTField k) (hi_btf lo_btf : BTField (k - 1)) :
    x = ⋘ hi_btf, lo_btf ⋙ ↔
  split (k:=k) (h_k:=h_pos) x = (hi_btf, lo_btf)

content: theorem unique_linear_decomposition_succ (k : ℕ) :
  ∀ (x : BTField (k+1)), ∃! (p : BTField k × BTField k),
    x = ⋘ p.1, p.2 ⋙

content: lemma algebraMap_adjacent_tower_succ_eq_Adjoin_of (k : ℕ) :
  (algebraMap (BTField k) (BTField (k + 1))) = of (poly k)

content: lemma algebraMap_adjacent_tower_def (l : ℕ) :
  (algebraMap (BTField l) (BTField (l + 1))) = canonicalEmbedding l

content: lemma binaryTowerAlgebra_def (l r : ℕ) (h_le : l ≤ r) :
    @binaryAlgebraTower (l:=l) (r:=r) (h_le:=h_le)
    = (towerAlgebraMap l r h_le).toAlgebra

content: lemma poly_natDegree_eq_2 (k : ℕ) : (poly (k:=k)).natDegree = 2

content: lemma BTField.cast_BTField_eq (k m : ℕ) (h_eq : k = m) :
  BTField k = BTField m

content: @[simp]
theorem BTField.RingHom_cast_dest_apply (k m n : ℕ) (h_eq : m = n)
  (f : BTField k →+* BTField m) (x : BTField k) :
    (cast (BTField.RingHom_eq_of_dest_eq (k:=k) (m:=m) (n:=n) h_eq) f) x
    = cast (by apply cast_BTField_eq (h_eq:=h_eq)) (f x)

content: @[simp]
theorem BTField.RingHom_eq_of_dest_eq (k m n : ℕ) (h_eq : m = n) :
  (BTField k →+* BTField m) = (BTField k →+* BTField n)

content: lemma towerAlgebraMap_succ (l r : ℕ) (h_le : l ≤ r) :
  towerAlgebraMap (l:=l) (r:=r+1) (h_le:=by omega) =
  (towerAlgebraMap (l:=r) (r:=r+1) (h_le:=by omega)).comp
  (towerAlgebraMap (l:=l) (r:=r) (h_le:=by omega))

content: lemma join_eq_join_iff (k : ℕ) (h_pos : k > 0) (hi₁ hi₀ lo₁ lo₀ : BTField (k - 1)) :
    ⋘ hi₁, lo₁ ⋙ = ⋘ hi₀, lo₀ ⋙ ↔
  hi₁ = hi₀ ∧ lo₁ = lo₀

content: lemma split_join_via_add_smul_eq_iff_split (k : ℕ) (h_pos : k > 0)
    (hi_btf lo_btf : BTField (k - 1)) :
    split (k:=k) (h_k:=h_pos) (⋘ hi_btf, lo_btf ⋙) = (hi_btf, lo_btf)

-- Local definitions used:
content: def ConcreteBTField : ℕ → Type := fun k => BitVec (2 ^ k)

content: instance BitVec.instDCast : DCast Nat BitVec where
  dcast h := BitVec.cast h
  dcast_id := by admit /- proof elided -/

content: def fromNat {k : ℕ} (n : Nat) : ConcreteBTField k :=
  BitVec.ofNat (2 ^ k) n

content: instance ConcreteBTField.instDCast_local : DCast ℕ ConcreteBTField where
  dcast h_k_eq term_k1 := BitVec.cast (congrArg (fun n => 2 ^ n) h_k_eq) term_k1
  dcast_id := by admit /- proof elided -/

content: def zero {k : ℕ} : ConcreteBTField k := BitVec.zero (2 ^ k)

content: def one {k : ℕ} : ConcreteBTField k := 1#(2 ^ k)

content: def add {k : ℕ} (x y : ConcreteBTField k) : ConcreteBTField k := BitVec.xor x y

content: def neg {k : ℕ} (x : ConcreteBTField k) : ConcreteBTField k := x

content: def split {k : ℕ} (h : k > 0) (x : ConcreteBTField k) :
    ConcreteBTField (k - 1) × ConcreteBTField (k - 1) :=
  let lo_bits : BitVec (2 ^ (k - 1) - 1 - 0 + 1) :=
    BitVec.extractLsb (hi := 2 ^ (k - 1) - 1) (lo := 0) x
  let hi_bits : BitVec (2 ^ k - 1 - 2 ^ (k - 1) + 1) :=
    BitVec.extractLsb (hi := 2 ^ k - 1) (lo := 2 ^ (k - 1)) x
  have h_lo : 2 ^ (k - 1) - 1 - 0 + 1 = 2 ^ (k - 1) := by admit /- proof elided -/

content: def join {k : ℕ} (h_pos : k > 0) (hi lo : ConcreteBTField (k - 1)) : ConcreteBTField k :=

content: structure ConcreteBTFAddCommGroupProps (k : ℕ) where
  add_assoc : ∀ a b c : ConcreteBTField k, (a + b) + c = a + (b + c) := add_assoc
  add_comm : ∀ a b : ConcreteBTField k, a + b = b + a := add_comm
  add_zero : ∀ a : ConcreteBTField k, a + zero = a := add_zero
  zero_add : ∀ a : ConcreteBTField k, zero + a = a := zero_add
  add_neg : ∀ a : ConcreteBTField k, a + (neg a) = zero := neg_add_cancel

content: def mkAddCommGroupInstance {k : ℕ} : AddCommGroup (ConcreteBTField k) := {
  zero := zero
  neg := neg
  sub := fun x y => add x y
  add_assoc := add_assoc
  add_comm := add_comm
  zero_add := zero_add
  add_zero := add_zero
  nsmul := fun n x => if n % 2 = (0 : ℕ) then zero else x
  zsmul := fun (n : ℤ) x => if n % 2 = 0 then zero else x  
  neg_add_cancel := neg_add_cancel
  nsmul_succ := nsmul_succ
  zsmul_succ' := fun n a => zsmul_succ n a
  add := add
  zsmul_neg' := zsmul_neg' (k := k)
}

content: def Z (k : ℕ) : ConcreteBTField k :=
  if h_k : k = 0 then one
  else
    《 one (k:=k-1), zero (k:=k-1) 》

content: def equivProd {k : ℕ} (h_k_pos : k > 0) :
  ConcreteBTField k ≃ ConcreteBTField (k - 1) × ConcreteBTField (k - 1) where
  toFun := split h_k_pos
  invFun := fun (hi, lo) => 《 hi, lo 》
  left_inv := fun x => Eq.symm (join_of_split h_k_pos x _ _ rfl)
  right_inv := fun ⟨hi, lo⟩ => Eq.symm (split_of_join h_k_pos _ hi lo rfl)

content: def concrete_mul {k : ℕ} (a b : ConcreteBTField k) : ConcreteBTField k :=
  if h_k_zero : k = 0 then
    if a = zero then zero
    else if b = zero then zero
    else if a = one then b
    else if b = one then a
    else zero 
  else
    have h_k_gt_0 : k > 0 := by admit /- proof elided -/

content: def concrete_inv {k : ℕ} (a : ConcreteBTField k) : ConcreteBTField k :=
  if h_k_zero : k = 0 then
    if a = 0 then 0 else 1
  else
    if h_a_zero : a = 0 then 0
    else if h_a_one : a = 1 then 1
    else
      let h_k_gt_0 : k > 0 := Nat.zero_lt_of_ne_zero h_k_zero
      let (a_hi, a_lo) := split (k:=k) (h:=h_k_gt_0) a
      let prevZ := Z (k - 1)
      let a_lo_next := a_lo + concrete_mul a_hi prevZ
      let delta := concrete_mul a_lo a_lo_next + concrete_mul a_hi a_hi
      let delta_inverse := concrete_inv delta
      let out_hi := concrete_mul delta_inverse a_hi
      let out_lo := concrete_mul delta_inverse a_lo_next
      let res := 《 out_hi, out_lo 》
      res

content: def natCast {k : ℕ} (n : ℕ) : ConcreteBTField k := if n % 2 = 0 then zero else one

content: def natCast_zero {k : ℕ} : natCast (k:=k) 0 = zero :=

content: def natCast_succ {k : ℕ} (n : ℕ) : natCast (k:=k) (n + 1) = natCast (k:=k) n + 1 :=

content: def intCast {k : ℕ} (n : ℤ) : ConcreteBTField k := if n % 2 = 0 then zero else one

content: def intCast_ofNat {k : ℕ} (n : ℕ) : intCast (k:=k) (n : ℤ) = natCast n :=

content: def intCast_negSucc {k : ℕ} (n : ℕ) : intCast (k:=k) (Int.negSucc n)
  = - (↑(n + 1) : ConcreteBTField k) :=

content: structure ConcreteBTFRingProps (k : ℕ) extends (ConcreteBTFAddCommGroupProps k) where
  
  mul_eq : ∀ (a b : ConcreteBTField k) (h_k : k > 0)
    {a₁ a₀ b₁ b₀ : ConcreteBTField (k - 1)}
    (_h_a : (a₁, a₀) = split h_k a) (_h_b : (b₁, b₀) = split h_k b),
    concrete_mul a b =
      《 concrete_mul a₀ b₁ + concrete_mul b₀ a₁ + concrete_mul (concrete_mul a₁ b₁) (Z (k - 1)),
      concrete_mul a₀ b₀ + concrete_mul a₁ b₁ 》

  
  zero_mul : ∀ a : ConcreteBTField k, concrete_mul zero a = zero
  zero_mul' : ∀ a : ConcreteBTField k, concrete_mul 0 a = 0
  mul_zero : ∀ a : ConcreteBTField k, concrete_mul a zero = zero
  mul_zero' : ∀ a : ConcreteBTField k, concrete_mul a 0 = 0
  one_mul : ∀ a : ConcreteBTField k, concrete_mul one a = a
  mul_one : ∀ a : ConcreteBTField k, concrete_mul a one = a

  
  mul_assoc : ∀ a b c : ConcreteBTField k, concrete_mul (concrete_mul a b) c
    = concrete_mul a (concrete_mul b c)
  mul_left_distrib : ∀ a b c : ConcreteBTField k, concrete_mul a (b + c)
    = concrete_mul a b + concrete_mul a c
  mul_right_distrib : ∀ a b c : ConcreteBTField k, concrete_mul (a + b) c
    = concrete_mul a c + concrete_mul b c

content: structure ConcreteBTFDivisionRingProps (k : ℕ) extends (ConcreteBTFRingProps k) where
  
  mul_inv_cancel : ∀ a : ConcreteBTField k, a ≠ zero → concrete_mul a (concrete_inv a) = one

content: structure ConcreteBTFieldProps (k : ℕ) extends (ConcreteBTFDivisionRingProps k) where
  
  mul_comm : ∀ a b : ConcreteBTField k, concrete_mul a b = concrete_mul b a

content: def mkRingInstance {k : ℕ} (props : ConcreteBTFieldProps k) : Ring (ConcreteBTField k) where
  toAddCommGroup := mkAddCommGroupInstance
  toOne := inferInstance
  mul := concrete_mul
  mul_assoc := props.mul_assoc
  one_mul := props.one_mul
  mul_one := props.mul_one
  left_distrib := props.mul_left_distrib
  right_distrib := props.mul_right_distrib
  zero_mul := props.zero_mul
  mul_zero := props.mul_zero

  natCast n := natCast n
  natCast_zero := natCast_zero
  natCast_succ n := natCast_succ n
  intCast n := intCast n
  intCast_ofNat n := intCast_ofNat n
  intCast_negSucc n := intCast_negSucc n

content: def mkDivisionRingInstance {k : ℕ} (props : ConcreteBTFieldProps k)
    : DivisionRing (ConcreteBTField k) where
  toRing := mkRingInstance (k:=k) props
  inv := concrete_inv
  exists_pair_ne := concrete_exists_pair_ne (k := k)
  mul_inv_cancel := props.mul_inv_cancel
  inv_zero := concrete_inv_zero
  qsmul := (Rat.castRec · * ·)
  nnqsmul := (NNRat.castRec · * ·)

content: def mkFieldInstance {k : ℕ} (props : ConcreteBTFieldProps k) : Field (ConcreteBTField k) where
  toDivisionRing := mkDivisionRingInstance (k:=k) props
  mul_comm := props.mul_comm

content: structure ConcreteBTFStepResult (k : ℕ) extends (ConcreteBTFieldProps k) where
  instFintype : Fintype (ConcreteBTField k)
  fieldFintypeCard : Fintype.card (ConcreteBTField k) = 2^(2^k)
  
  sumZeroIffEq : ∀ (x y : ConcreteBTField k), x + y = 0 ↔ x = y
  traceMapEvalAtRootsIs1 :
    letI := mkFieldInstance (k:=k) (props:=toConcreteBTFieldProps)
    TraceMapProperty (ConcreteBTField k) (u:=Z k) k
  instIrreduciblePoly :
    letI := mkFieldInstance (k:=k) (props:=toConcreteBTFieldProps)
    (Irreducible (p := (definingPoly (s:=(Z k)))))

content: def liftBTFieldProps (k : ℕ) (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  ConcreteBTFieldProps (k + 1) := {
    zero_mul := concrete_zero_mul (prevBTFResult.toConcreteBTFieldProps),
    zero_mul' := fun a => by admit /- proof elided -/

content: def liftConcreteBTField (k : ℕ) (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  Field (ConcreteBTField (k + 1)) :=

content: def concreteCanonicalEmbedding (k : ℕ)
    (prevBTFieldProps : ConcreteBTFieldProps (k := (k)))
    (curBTFieldProps : ConcreteBTFieldProps (k := (k + 1))) :
  letI := mkFieldInstance prevBTFieldProps
  letI := mkFieldInstance curBTFieldProps
  ConcreteBTField k →+* ConcreteBTField (k + 1) :=

content: instance instAlgebraLiftConcreteBTField (k : ℕ)
  (prevBTFResult : ConcreteBTFStepResult (k := k)) :
  letI := mkFieldInstance (prevBTFResult.toConcreteBTFieldProps)
  letI := liftConcreteBTField (k:=k) prevBTFResult
  Algebra (ConcreteBTField k) (ConcreteBTField (k + 1)) :=
  letI := mkFieldInstance (prevBTFResult.toConcreteBTFieldProps)
  letI := liftConcreteBTField (k:=k) prevBTFResult
  RingHom.toAlgebra (R:=ConcreteBTField k) (S:=ConcreteBTField (k + 1))
    (i:=(concreteCanonicalEmbedding (k:=k)
      (prevBTFieldProps:=prevBTFResult.toConcreteBTFieldProps)
      (curBTFieldProps:=liftBTFieldProps (k:=k) (prevBTFResult:=prevBTFResult))))

content: def getBTFResult (k : ℕ) : ConcreteBTFStepResult k :=
  match k with
  | 0 =>
    let base : ConcreteBTFieldProps 0 := {
      mul_eq := fun a b h_k _ _ _ _ _ _ => by admit /- proof elided -/
| c1_one
        · 
          rw [c1_zero] at h_mul
          
          simp at h_mul
        · 
          rcases c2_cases with c2_zero | c2_one
          · 
            rw [c2_zero] at h_mul
            
            simp at h_mul
          · 
            
            exact ⟨c1_one, c2_one⟩
      
      have specialElement_eq_zero : specialElement = 0 := by admit /- proof elided -/

content: def canonicalAlgMap (k : ℕ) := concreteCanonicalEmbedding (k:=k)
  (prevBTFieldProps:= ((getBTFResult k).toConcreteBTFieldProps))
  (curBTFieldProps:= ((getBTFResult (k + 1)).toConcreteBTFieldProps))

content: def concreteTowerAlgebraMap (l r : ℕ) (h_le : l ≤ r) :
    ConcreteBTField l →+* ConcreteBTField r :=

content: instance instAlgebraTowerConcreteBTF : AlgebraTower (ConcreteBTField) where
  algebraMap := concreteTowerAlgebraMap
  commutes' := by admit /- proof elided -/

content: def ConcreteBTFieldAlgebra {l r : ℕ} (h_le : l ≤ r) :
    Algebra (ConcreteBTField l) (ConcreteBTField r) := instAlgebraTowerConcreteBTF.toAlgebra h_le

content: def join_via_add_smul (k : ℕ) (h_pos : k > 0) (hi_btf lo_btf : ConcreteBTField (k - 1)) :
    ConcreteBTField k :=

content: def basisSucc (k : ℕ) : Basis (Fin 2) (ConcreteBTField k) (ConcreteBTField (k + 1)) :=

content: def powerBasisSucc (k : ℕ) :
    PowerBasis (ConcreteBTField k) (ConcreteBTField (k + 1)) :=

content: noncomputable def towerEquiv_zero : RingEquiv (R:=GF(2)) (S:=ConcreteBTField 0) :=  {
  toFun := fun x => if x = 0 then 0 else 1,
  invFun := fun x => if x = 0 then 0 else 1,
  left_inv := fun x => by admit /- proof elided -/

content: noncomputable def towerRingEquiv0 : BTField 0 ≃+* ConcreteBTField 0 :=

content: noncomputable def towerRingEquivFromConcrete0 : ConcreteBTField 0 ≃+* BTField 0 :=

content: noncomputable def towerRingHomForwardMap (k : ℕ) : ConcreteBTField k → BTField k :=

content: noncomputable def towerRingHomBackwardMap (k : ℕ) : BTField k → ConcreteBTField k :=

content: structure TowerEquivResult (k : ℕ) where
  ringEquiv : ConcreteBTField k ≃+* BTField k
  ringEquivForwardMapEq : ringEquiv = towerRingHomForwardMap k

content: noncomputable def towerEquiv (n : ℕ) : TowerEquivResult n :=

-- Local lemmas used:
content: lemma cast_ConcreteBTField_eq (k m : ℕ) (h_eq : k = m) :
  ConcreteBTField k = ConcreteBTField m

content: theorem BitVec.dcast_id {n : Nat} (bv : BitVec n) :
  DCast.dcast (Eq.refl n) bv = bv

content: theorem BitVec.dcast_bitvec_eq {l r val : ℕ} (h_width_eq : l = r) :
    dcast h_width_eq (BitVec.ofNat l val) = BitVec.ofNat r val

content: theorem BitVec.dcast_bitvec_toNat_eq {w w2 : ℕ} (x : BitVec w) (h_width_eq : w = w2) :
    BitVec.toNat x = BitVec.toNat (dcast (h_width_eq) x)

content: theorem BitVec.dcast_bitvec_eq_zero {l r : ℕ} (h_width_eq : l = r) :
  dcast (h_width_eq) 0#(l) = 0#(r)

content: theorem BitVec.dcast_bitvec_extractLsb_eq {w hi1 lo1 hi2 lo2 : ℕ}
    (x : BitVec w) (h_lo_eq : lo1 = lo2)
    (h_width_eq : hi1 - lo1 + 1 = hi2 - lo2 + 1) :
    dcast h_width_eq (BitVec.extractLsb (hi:=hi1) (lo:=lo1) x)
      = BitVec.extractLsb (hi:=hi2) (lo:=lo2) (x)

content: theorem BitVec.eq_mp_eq_dcast {w w2 : ℕ} (x : BitVec w) (h_width_eq : w = w2)
  (h_bitvec_eq : BitVec w = BitVec w2 := by rw [h_width_eq]) :
  Eq.mp (h:=h_bitvec_eq) (a:=x) = dcast (h_width_eq) (x)

content: theorem BitVec.extractLsb_concat_hi {hi_size lo_size : ℕ} (hi : BitVec hi_size)
  (lo : BitVec lo_size) (h_hi : hi_size > 0) :
  BitVec.extractLsb (hi:=hi_size + lo_size - 1) (lo:=lo_size)
  (BitVec.append (msbs:=hi) (lsbs:=lo)) = dcast (by
    rw [←Nat.sub_add_comm (by omega), Nat.sub_add_cancel (by omega), Nat.add_sub_cancel]
  ) hi

content: theorem BitVec.extractLsb_concat_lo {hi_size lo_size : ℕ} (hi : BitVec hi_size)
  (lo : BitVec lo_size) (h_lo : lo_size > 0) : BitVec.extractLsb (hi:=lo_size - 1) (lo:=0)
  (BitVec.append (msbs:=hi) (lsbs:=lo)) = dcast (by
    rw [←Nat.sub_add_comm (h:=by omega), Nat.sub_add_cancel (h:=by omega), Nat.sub_zero]
  ) lo

content: theorem Nat.shiftRight_lo_mod_2_pow_hi_shiftLeft_lo (n hi_len lo_len : ℕ)
  (h_n : n < 2 ^ (hi_len + lo_len)) :
  (((n >>> lo_len) % (2 ^ hi_len)) <<< lo_len) = (n - n % 2 ^ lo_len)

content: theorem Nat.reconstruct_from_hi_and_lo_parts (n hi_len lo_len : ℕ)
    (h_n : n < 2 ^ (hi_len + lo_len)) :
    n = (((n >>> lo_len) % (2 ^ hi_len)) <<< lo_len) + (n % (2 ^ lo_len))

content: theorem Nat.reconstruct_from_hi_and_lo_parts_or_ver (n hi_len lo_len : ℕ)
  (h_n : n < 2 ^ (hi_len + lo_len)) :
    n = (((n >>> lo_len) % (2 ^ hi_len)) <<< lo_len) ||| (n % (2 ^ lo_len))

content: theorem BitVec.eq_append_iff_extract {lo_size hi_size : ℕ} (lo : BitVec lo_size)
  (hi : BitVec hi_size) (h_hi_gt_0 : hi_size > 0) (h_lo_gt_0 : lo_size > 0)
  (x : BitVec (hi_size + lo_size)) : x = dcast (by rfl) (BitVec.append (msbs:=hi) (lsbs:=lo)) ↔
  hi = dcast (by omega) (BitVec.extractLsb (hi:=hi_size + lo_size - 1) (lo:=lo_size) x) ∧
  lo = dcast (by omega) (BitVec.extractLsb (hi:=lo_size - 1) (lo:=0) x)

content: lemma one_le_sub_middle_of_pow2 {k : ℕ} (h_k : 1 ≤ k) : 1 ≤ 2 ^ k - 2 ^ (k - 1)

content: lemma sub_middle_of_pow2_with_one_canceled {k : ℕ} (h_k : 1 ≤ k) : 2 ^ k - 1 - 2 ^ (k - 1) + 1
  = 2 ^ (k - 1)

content: lemma h_sub_middle {k : ℕ} (h_pos : k > 0) : 2 ^ k - 1 - 2 ^ (k - 1) + 1 = 2 ^ (k - 1)

content: lemma h_middle_sub {k : ℕ} : 2 ^ (k - 1) - 1 - 0 + 1 = 2 ^ (k - 1)

content: lemma h_sum_two_same_pow2 {k : ℕ} (h_pos : k > 0) : 2 ^ (k - 1) + 2 ^ (k - 1) = 2 ^ k

content: lemma cast_join {k n : ℕ} (h_pos : k > 0) (hi lo : ConcreteBTField (k - 1)) (heq : k = n) :
  join (k:=k) h_pos hi lo = cast (by rw [heq])
    (join (k:=n) (by omega) (cast (by subst heq; rfl) hi) (lo:=cast (by subst heq; rfl) lo))

content: lemma zero_is_0 {k : ℕ} : (zero (k:=k)) = (0 : ConcreteBTField k)

content: theorem BitVec.extractLsb_eq_shift_ofNat {n : Nat} (x : BitVec n) (l r : Nat) :
    BitVec.extractLsb r l x = BitVec.ofNat (r - l + 1) (x.toNat >>> l)

content: theorem setWidth_eq_ofNat_mod {n num_bits : Nat} (x : BitVec n) :
  BitVec.setWidth num_bits x = BitVec.ofNat num_bits (x.toNat % 2 ^ num_bits)

content: theorem BitVec.extractLsb_eq_and_pow_2_minus_1_ofNat {n num_bits : Nat}
  (h_num_bits : num_bits > 0) (x : BitVec n) :
  BitVec.extractLsb (hi:= num_bits - 1) (lo := 0) x =
    BitVec.ofNat (num_bits - 1 - 0 + 1) (x.toNat &&& (2 ^ num_bits - 1))

content: theorem split_bitvec_eq_iff_fromNat {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField k)
  (hi_btf lo_btf : ConcreteBTField (k - 1)) :
  split h_pos x = (hi_btf, lo_btf) ↔
  (hi_btf = fromNat (k:=k - 1) (x.toNat >>> 2 ^ (k - 1)) ∧
  lo_btf = fromNat (k:=k - 1) (x.toNat &&& (2 ^ (2 ^ (k - 1)) - 1)))

content: theorem join_eq_iff_dcast_extractLsb {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField k)
  (hi_btf lo_btf : ConcreteBTField (k - 1)) :
  x = 《 hi_btf, lo_btf 》 ↔
  (hi_btf = dcast (h_sub_middle h_pos) (BitVec.extractLsb (hi := 2 ^ k - 1) (lo := 2 ^ (k - 1)) x) ∧
  lo_btf = dcast (h_middle_sub) (BitVec.extractLsb (hi := 2 ^ (k - 1) - 1) (lo := 0) x))

content: theorem join_eq_bitvec_iff_fromNat {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField k)
  (hi_btf lo_btf : ConcreteBTField (k - 1)) :
  x = 《 hi_btf, lo_btf 》 ↔
  (hi_btf = fromNat (k:=k - 1) (x.toNat >>> 2 ^ (k - 1)) ∧
  lo_btf = fromNat (k:=k - 1) (x.toNat &&& (2 ^ (2 ^ (k - 1)) - 1)))

content: theorem join_of_split {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField k)
    (hi_btf lo_btf : ConcreteBTField (k - 1))
    (h_split_eq : split h_pos x = (hi_btf, lo_btf)) :
    x = 《 hi_btf, lo_btf 》

content: theorem split_of_join {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField k)
    (hi_btf lo_btf : ConcreteBTField (k - 1))
    (h_join : x = 《hi_btf, lo_btf》) :
    (hi_btf, lo_btf) = split h_pos x

content: theorem split_zero {k : ℕ} (h_pos : k > 0) : split h_pos zero = (zero, zero)

content: @[simp]
theorem ConcreteBTField.RingHom_eq_of_dest_eq (k m n : ℕ) (h_eq : m = n) :
    (ConcreteBTField k →+* ConcreteBTField m)
    = (ConcreteBTField k →+* ConcreteBTField n)

content: @[simp]
theorem ConcreteBTField.RingHom_cast_dest_apply (k m n : ℕ) (h_eq : m = n)
  (f : ConcreteBTField k →+* ConcreteBTField m) (x : ConcreteBTField k) :
    (cast (ConcreteBTField.RingHom_eq_of_dest_eq (k:=k) (m:=m) (n:=n) h_eq) f) x
    = cast (by apply cast_ConcreteBTField_eq (h_eq:=h_eq)) (f x)

content: lemma concreteTowerAlgebraMap_id (k : ℕ) :
    concreteTowerAlgebraMap (h_le:=by omega) = RingHom.id (ConcreteBTField k)

content: lemma concreteTowerAlgebraMap_succ_1 (k : ℕ) :
  concreteTowerAlgebraMap (l:=k) (r:=k + 1) (h_le:=by omega) = canonicalAlgMap k

content: lemma concreteTowerAlgebraMap_succ (l r : ℕ) (h_le : l ≤ r) :
  concreteTowerAlgebraMap (l:=l) (r:=r + 1) (h_le:=by omega) =
  (concreteTowerAlgebraMap (l:=r) (r:=r + 1) (h_le:=by omega)).comp
  (concreteTowerAlgebraMap (l:=l) (r:=r) (h_le:=by omega))

content: lemma split_algebraMap_eq_zero_x {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField (k - 1)) :
  letI instAlgebra := ConcreteBTFieldAlgebra (l:=k-1) (r:=k) (h_le:=by omega)
  split h_pos (algebraMap (ConcreteBTField (k - 1)) (ConcreteBTField k) x) = (0, x)

content: lemma algebraMap_succ_eq_zero_x {k : ℕ} (h_pos : k > 0) (x : ConcreteBTField (k - 1)) :
  letI instAlgebra := ConcreteBTFieldAlgebra (l:=k-1) (r:=k) (h_le:=by omega)
  algebraMap (ConcreteBTField (k - 1)) (ConcreteBTField k) x = 《 0, x 》

content: lemma algebraMap_eq_zero_x {i j : ℕ} (h_le : i < j) (x : ConcreteBTField i) :
    letI instAlgebra := ConcreteBTFieldAlgebra (l:=i) (r:=j) (h_le:=by omega)
    letI instAlgebraPred := ConcreteBTFieldAlgebra (l:=i) (r:=j-1) (h_le:=by omega)
    algebraMap (ConcreteBTField i) (ConcreteBTField j) x
      = 《 0, algebraMap (ConcreteBTField i) (ConcreteBTField (j-1)) x 》

content: lemma towerRingHomForwardMap_zero {k : ℕ} :
  (towerRingHomForwardMap k) 0 = 0

content: lemma towerRingHomForwardMap_split_eq (k : ℕ) (h_pos : k > 0) (x : ConcreteBTField k) :
  let p := split (k:=k) (h:=h_pos) x
  towerRingHomForwardMap (k:=k) (x) =
    BinaryTower.join_via_add_smul (k:=k) (h_pos:=h_pos)
      (hi_btf := towerRingHomForwardMap (k:=k-1) (p.1))
      (lo_btf := towerRingHomForwardMap (k:=k-1) (p.2))

content: lemma towerRingHomForwardMap_join {k : ℕ} (h_pos : k > 0) (hi lo : ConcreteBTField (k - 1)) :
  towerRingHomForwardMap (k:=k) (《 hi, lo 》) =
    BinaryTower.join_via_add_smul (k:=k) (h_pos:=by omega)
      (hi_btf := towerRingHomForwardMap (k:=k-1) hi)
      (lo_btf := towerRingHomForwardMap (k:=k-1) lo)

-- Target theorem and proof:
lemma towerEquiv_commutes_left_diff (i d : ℕ) : ∀ r : ConcreteBTField i,
  (AlgebraTower.algebraMap i (i+d) (by omega)) ((towerEquiv i).ringEquiv r) =
  (towerEquiv (i+d)).ringEquiv ((AlgebraTower.algebraMap i (i+d) (by omega)) r)
:= by
  -- If d = 0, then this is trivial
  -- For d > 0 : let j = i+d
    -- lhs of goal : right => 《 0, ringMap x 》 => up => 《 algMap 0 = 0, algMap (ringMap x) 》
    -- rhs of goal : up => 《 0, algMap x 》 => right => 《 ringMap 0 = 0, ringMap (algMap x) 》
    -- where both `algMap (ringMap x)` and `ringMap (algMap x)` are in `BTField (j-1)`
  -- => Strategy : For each i => do induction upwards on d
  change ∀ r : ConcreteBTField i,
    (BinaryTower.towerAlgebraMap (l:=i) (r:=i+d) (h_le:=by omega)) ((towerEquiv i).ringEquiv r) =
    (towerEquiv (i+d)).ringEquiv ((concreteTowerAlgebraMap i (i+d) (by omega)) r)
  induction d using Nat.rec with
  | zero =>
    intro r
    simp only [Nat.add_zero]
    rw [BinaryTower.towerAlgebraMap_id, concreteTowerAlgebraMap_id]
    rfl
  | succ d' ih =>
    intro r
    letI instAbstractAlgebra : Algebra (BTField i) (BTField (i + d' + 1)) :=
      binaryAlgebraTower (by omega)
    let : Algebra (ConcreteBTField i) (ConcreteBTField (i + d')) :=
      ConcreteBTFieldAlgebra (l:=i) (r:=i+d') (h_le:=by omega)
    letI instConcreteAlgebra : Algebra (ConcreteBTField i) (ConcreteBTField (i + d' + 1)) :=
      ConcreteBTFieldAlgebra (l:=i) (r:=i+d'+1) (h_le:=by omega)
    change (algebraMap (R:=BTField i) (A:=BTField (i + d' + 1))) ((towerEquiv i).ringEquiv r) =
      (towerEquiv (i + d' + 1)).ringEquiv ((algebraMap (R:=ConcreteBTField i)
      (A:=ConcreteBTField (i + d' + 1))) r)
    have h_concrete_algMap_eq_zero_x := algebraMap_eq_zero_x (i:=i) (j:=i+d'+1) (h_le:=by omega) r
    simp only [Nat.add_one_sub_one] at h_concrete_algMap_eq_zero_x
    rw [algebraMap, Algebra.algebraMap] at h_concrete_algMap_eq_zero_x
    have h_abstract_algMap_eq_zero_x := BinaryTower.algebraMap_eq_zero_x (i:=i) (j:=i+d'+1)
      (h_le:=by omega) ((towerEquiv i).ringEquiv r)
    simp only [Nat.add_one_sub_one] at h_abstract_algMap_eq_zero_x
    conv_lhs =>
      rw! [h_abstract_algMap_eq_zero_x]
    conv_rhs =>
      rw [algebraMap, Algebra.algebraMap]
      simp only [BTField.eq_1, CommRing.eq_1, BTFieldIsField.eq_1, instConcreteAlgebra]
      rw! [h_concrete_algMap_eq_zero_x] -- split algebraMap
      -- Now change `BinaryTowerAux (i + d' + 1)).fst` back to `BTField (i + d' + 1)`
      -- for definitional equality, otherwise we can't `rw [ringEquivForwardMapEq]`
      change (towerEquiv (i + d' + 1)).ringEquiv (join (h_pos:=by omega) 0
        ((algebraMap (ConcreteBTField i) (ConcreteBTField (i + d'))) r))
      rw [(towerEquiv (i+d'+1)).ringEquivForwardMapEq]
      -- now convert to BinaryTower.join_via_add_smul
      rw [towerRingHomForwardMap_join (k:=i+d'+1) (h_pos:=by omega)]
      simp only [Nat.add_one_sub_one]
    -- ⊢ BinaryTower.join_via_add_smul ⋯ = BinaryTower.join_via_add_smul ⋯ =
    rw [BinaryTower.join_eq_join_iff]
    constructor
    · rw [towerRingHomForwardMap_zero]
    · let h := ih (r:=r)
      change (BinaryTower.towerAlgebraMap (l:=i) (r:=i+d')
        (h_le:=by omega)) ((towerEquiv i).ringEquiv r) =
        towerRingHomForwardMap (i + d') ((concreteTowerAlgebraMap i (i + d') (by omega)) r)
      rw [h]
      rw [(towerEquiv (i+d')).ringEquivForwardMapEq]