/-! FrcCore/Godel.lean for the live instance: the core module with the 14 modules it rests on inlined (Nat, Pigeonhole, Shell, Series, FrameCore, Frame, Parity, Transform, Orbit, Sum, Theme.Logic, Theme.SecondOrder, Theme.Formation, Keys.Logic); plain Lean, no Mathlib, no axioms. Generated by make_core_web.py — edit the modules, not this file. The ledger predicates are the declarations named by their accession keys (`p10015`) at the end of the module; their axioms are printed below them. -/ /-! inlined: FrcCore/Nat.lean -/ /-! # FrcCore.Nat — the arithmetic the shells stand on, from first principles No Mathlib, no `simp`, no `omega`: every theorem here is checked by `#print axioms` to depend on no axiom at all. Lean's own core library proves most of these with `propext` for convenience (see `reports/lean-axioms-probe-20260917/core_probe.log`); they are re-derived here by induction from the axiom-free primitives (`Nat.rec`, `Nat.add_comm`, `Nat.mul_comm`, `Nat.left_distrib`, `Nat.mod_lt`, `Nat.le.dest`, `ite_eq_left`, `ite_eq_right`, `Decidable.em`). The division algorithm is obtained from the definition of `Nat.mod` in `Init.Prelude` (the wrapper around `Nat.modCore`, itself a fuel recursion): `mod_eq_of_lt`, `mod_eq_sub_mod`, `mod_spec` (`x = p·q + x % p`) and `mod_unique` (the remainder is determined by any such decomposition). Everything about residues mod `p` follows from those four. Since the ledger migration (task LM17) it also holds `isPrime`, primality by trial division (from 10-dimensions), and since task LM22 `isPrime_of_bounded`, trial division up to the square root (from 14-entropy). -/ namespace FRC.Nat /-! ## Cancellation and subtraction -/ theorem add_left_cancel {a b c : Nat} (h : a + b = a + c) : b = c := by induction a with | zero => rw [Nat.zero_add, Nat.zero_add] at h; exact h | succ a ih => apply ih rw [Nat.succ_add, Nat.succ_add] at h exact Nat.succ.inj h theorem add_right_cancel {a b c : Nat} (h : a + c = b + c) : a = b := add_left_cancel (a := c) (by rw [Nat.add_comm c a, Nat.add_comm c b]; exact h) theorem add_sub_cancel (n m : Nat) : n + m - m = n := by induction m with | zero => rfl | succ m ih => rw [Nat.add_succ, Nat.succ_sub_succ]; exact ih theorem add_sub_cancel_left (n m : Nat) : n + m - n = m := by rw [Nat.add_comm]; exact add_sub_cancel m n theorem sub_add_cancel {n m : Nat} (h : m ≤ n) : n - m + m = n := by match Nat.le.dest h with | ⟨k, hk⟩ => rw [← hk, add_sub_cancel_left, Nat.add_comm] theorem sub_add_self_eq_zero (m : Nat) : ∀ k, m - (m + k) = 0 | 0 => Nat.sub_self m | k + 1 => by show Nat.pred (m - (m + k)) = 0; rw [sub_add_self_eq_zero m k]; rfl theorem sub_eq_zero_of_le {m n : Nat} (h : m ≤ n) : m - n = 0 := match Nat.le.dest h with | ⟨k, hk⟩ => by rw [← hk]; exact sub_add_self_eq_zero m k theorem add_sub_of_le {n m : Nat} (h : m ≤ n) : m + (n - m) = n := by rw [Nat.add_comm]; exact sub_add_cancel h theorem sub_lt_of_lt_add {x y z : Nat} (h : x < y + z) (hy : y ≤ x) : x - y < z := by refine Nat.lt_of_add_lt_add_right (n := y) ?_ rw [sub_add_cancel hy, Nat.add_comm z y] exact h theorem le_of_add_le_add_left {a b c : Nat} (h : a + b ≤ a + c) : b ≤ c := by induction a with | zero => rw [Nat.zero_add, Nat.zero_add] at h; exact h | succ a ih => apply ih; rw [Nat.succ_add, Nat.succ_add] at h; exact Nat.le_of_succ_le_succ h theorem le_of_add_le_add_right {a b c : Nat} (h : b + a ≤ c + a) : b ≤ c := le_of_add_le_add_left (a := a) (by rw [Nat.add_comm a b, Nat.add_comm a c]; exact h) theorem sub_le_of_le_add {a b c : Nat} (h : a ≤ c + b) : a - b ≤ c := by have := Nat.sub_le_sub_right h b rw [add_sub_cancel] at this; exact this theorem le_add_of_sub_le {a b c : Nat} (hb : b ≤ a) (h : a - b ≤ c) : a ≤ c + b := by have := Nat.add_le_add_right h b rw [sub_add_cancel hb] at this; exact this theorem le_sub_of_add_le {a b c : Nat} (h : c + b ≤ a) : c ≤ a - b := by have := Nat.sub_le_sub_right h b rw [add_sub_cancel] at this; exact this theorem succ_ne_zero (n : Nat) : n + 1 ≠ 0 := fun h => Nat.noConfusion h theorem pos_of_lt {a b : Nat} (h : a < b) : 0 < b := Nat.lt_of_le_of_lt (Nat.zero_le a) h /-! ## Multiplication -/ theorem mul_assoc (a b c : Nat) : a * b * c = a * (b * c) := by induction c with | zero => rfl | succ c ih => rw [Nat.mul_succ, Nat.mul_succ, ih, Nat.left_distrib] theorem add_mul (a b c : Nat) : (a + b) * c = a * c + b * c := by rw [Nat.mul_comm, Nat.left_distrib, Nat.mul_comm c a, Nat.mul_comm c b] theorem add_add_add_comm (a b c d : Nat) : a + b + (c + d) = a + c + (b + d) := by rw [Nat.add_assoc, Nat.add_assoc, Nat.add_left_comm b] theorem mul_left_comm (a b c : Nat) : a * (b * c) = b * (a * c) := by rw [← mul_assoc, Nat.mul_comm a b, mul_assoc] theorem mul_lt_mul_of_lt_of_pos {a b c : Nat} (h : a < b) (hc : 0 < c) : a * c < b * c := by rw [Nat.mul_comm a c, Nat.mul_comm b c] exact Nat.mul_lt_mul_of_pos_left h hc /-! ## The division algorithm, from the definition of `Nat.mod` -/ section mod /-- The fuel of `Nat.modCore.go` does not matter once it exceeds the dividend. -/ theorem modCore_go_fuel {y : Nat} (hy : 0 < y) : ∀ (f1 f2 x : Nat) (h1 : x < f1) (h2 : x < f2), Nat.modCore.go y hy f1 x h1 = Nat.modCore.go y hy f2 x h2 := by intro f1 induction f1 with | zero => intro f2 x h1; exact absurd h1 (Nat.not_lt_zero x) | succ f1 ih => intro f2 x h1 h2 cases f2 with | zero => exact absurd h2 (Nat.not_lt_zero x) | succ f2 => show (if h : y ≤ x then Nat.modCore.go y hy f1 (x - y) _ else x) = (if h : y ≤ x then Nat.modCore.go y hy f2 (x - y) _ else x) exact match Nat.decLe y x with | .isTrue h => by rw [dite_eq_left h, dite_eq_left h]; exact ih f2 (x - y) _ _ | .isFalse h => by rw [dite_eq_right h, dite_eq_right h] theorem modCore_eq' (x y : Nat) (hy : 0 < y) : Nat.modCore x y = if y ≤ x then Nat.modCore (x - y) y else x := by unfold Nat.modCore rw [dite_eq_left hy] show (if h : y ≤ x then Nat.modCore.go y hy x (x - y) _ else x) = _ exact match Nat.decLe y x with | .isTrue h => by rw [dite_eq_left h, ite_eq_left h, dite_eq_left hy] exact modCore_go_fuel hy x (x - y + 1) (x - y) _ _ | .isFalse h => by rw [dite_eq_right h, ite_eq_right h] theorem modCore_eq_mod' (n m : Nat) (hm : 0 < m) : Nat.modCore n m = n % m := by cases n with | zero => show Nat.modCore 0 m = 0 rw [modCore_eq' 0 m hm, ite_eq_right (Nat.not_le_of_lt hm)] | succ n => show Nat.modCore (n + 1) m = ite (m ≤ n + 1) (Nat.modCore (n + 1) m) (n + 1) exact match Nat.decLe m (n + 1) with | .isTrue h => by rw [ite_eq_left h] | .isFalse h => by rw [ite_eq_right h, modCore_eq' _ _ hm, ite_eq_right h] theorem mod_eq_of_lt {x y : Nat} (h : x < y) : x % y = x := by cases x with | zero => rfl | succ n => show ite (y ≤ n + 1) (Nat.modCore (n + 1) y) (n + 1) = n + 1 rw [ite_eq_right (Nat.not_le_of_lt h)] theorem mod_eq_sub_mod {x y : Nat} (hy : 0 < y) (h : y ≤ x) : x % y = (x - y) % y := by rw [← modCore_eq_mod' x y hy, modCore_eq' x y hy, ite_eq_left h, modCore_eq_mod' _ _ hy] /-- The division algorithm: `x = p·q + x % p` for some `q`. -/ theorem mod_spec (p : Nat) (hp : 0 < p) : ∀ x : Nat, ∃ q, x = p * q + x % p := by intro x induction x using Nat.strongRecOn with | _ x ih => exact match Nat.decLe p x with | .isTrue h => match ih (x - p) (Nat.sub_lt (Nat.lt_of_lt_of_le hp h) hp) with | ⟨q, hq⟩ => ⟨q + 1, by rw [mod_eq_sub_mod hp h, Nat.mul_succ, Nat.add_assoc, Nat.add_comm p, ← Nat.add_assoc, ← hq, sub_add_cancel h]⟩ | .isFalse h => ⟨0, by rw [mod_eq_of_lt (Nat.lt_of_not_le h), Nat.mul_zero, Nat.zero_add]⟩ /-- Uniqueness of the decomposition: the quotients agree. -/ theorem quot_unique {p q q' r r' : Nat} (hr : r < p) (hr' : r' < p) (h : p * q + r = p * q' + r') : q = q' := by have key : ∀ {q q' r r' : Nat}, r < p → r' < p → p * q + r = p * q' + r' → ¬ q < q' := by intro q q' r r' hr hr' h hlt have h1 : p * (q + 1) ≤ p * q' := Nat.mul_le_mul_left p hlt have h2 : p * q + r < p * q + p := Nat.add_lt_add_left hr _ rw [Nat.mul_succ] at h1 have h3 : p * q + r < p * q' + r' := Nat.lt_of_lt_of_le h2 (Nat.le_trans h1 (Nat.le_add_right _ _)) rw [h] at h3 exact Nat.lt_irrefl _ h3 exact match Nat.lt_or_ge q q' with | .inl hlt => absurd hlt (key hr hr' h) | .inr hge => match Nat.lt_or_ge q' q with | .inl hlt => absurd hlt (key hr' hr h.symm) | .inr hge' => Nat.le_antisymm hge' hge /-- The remainder is determined: if `x = p·q + r` with `r < p`, then `r = x % p`. -/ theorem mod_unique {p x q r : Nat} (hr : r < p) (h : x = p * q + r) : x % p = r := by have hp : 0 < p := pos_of_lt hr match mod_spec p hp x with | ⟨q', hq'⟩ => have hqq : q' = q := quot_unique (Nat.mod_lt x hp) hr (by rw [← hq', ← h]) rw [hqq] at hq' rw [h] at hq' rw [h] exact (add_left_cancel hq').symm theorem mod_mod (x p : Nat) (hp : 0 < p) : x % p % p = x % p := mod_eq_of_lt (Nat.mod_lt x hp) theorem add_mod (a b p : Nat) (hp : 0 < p) : (a + b) % p = (a % p + b % p) % p := by match mod_spec p hp a, mod_spec p hp b, mod_spec p hp (a % p + b % p) with | ⟨qa, ha⟩, ⟨qb, hb⟩, ⟨qc, hc⟩ => apply mod_unique (q := qa + qb + qc) (Nat.mod_lt _ hp) rw [Nat.left_distrib, Nat.left_distrib, Nat.add_assoc, ← hc] rw [Nat.add_assoc, Nat.add_left_comm (p * qb), ← Nat.add_assoc, ← ha, ← hb] theorem add_mul_mod_self_left (x k p : Nat) (hp : 0 < p) : (p * k + x) % p = x % p := by match mod_spec p hp x with | ⟨q, hq⟩ => apply mod_unique (q := k + q) (Nat.mod_lt x hp) rw [Nat.left_distrib, Nat.add_assoc, ← hq] theorem mul_mod_left' (a b p : Nat) (hp : 0 < p) : (a * b) % p = (a % p * b) % p := by match mod_spec p hp a with | ⟨qa, ha⟩ => have e : a * b = p * (qa * b) + a % p * b := by rw [← mul_assoc, ← add_mul, ← ha] rw [e, add_mul_mod_self_left _ _ _ hp] theorem mul_mod (a b p : Nat) (hp : 0 < p) : (a * b) % p = (a % p * (b % p)) % p := by rw [mul_mod_left' a b p hp, Nat.mul_comm (a % p) b, mul_mod_left' b (a % p) p hp, Nat.mul_comm (b % p) (a % p)] theorem mod_self (p : Nat) (hp : 0 < p) : p % p = 0 := mod_unique hp (by rw [Nat.mul_one, Nat.add_zero]) theorem zero_mod (p : Nat) : 0 % p = 0 := rfl theorem mod_add_mod (a b p : Nat) (hp : 0 < p) : (a % p + b) % p = (a + b) % p := by rw [add_mod a b p hp, add_mod (a % p) b p hp, mod_mod _ _ hp] theorem add_mod_mod (a b p : Nat) (hp : 0 < p) : (a + b % p) % p = (a + b) % p := by rw [add_mod a b p hp, add_mod a (b % p) p hp, mod_mod _ _ hp] theorem mod_mul_mod (a b p : Nat) (hp : 0 < p) : (a % p * b) % p = (a * b) % p := (mul_mod_left' a b p hp).symm theorem mul_mod_mod (a b p : Nat) (hp : 0 < p) : (a * (b % p)) % p = (a * b) % p := by rw [mul_mod a (b % p) p hp, mod_mod _ _ hp, ← mul_mod a b p hp] theorem mod_lt' (x : Nat) {p : Nat} (hp : 0 < p) : x % p < p := Nat.mod_lt x hp end mod /-! ## Powers -/ theorem pow_succ' (a n : Nat) : a ^ (n + 1) = a ^ n * a := rfl theorem pow_add (a m n : Nat) : a ^ (m + n) = a ^ m * a ^ n := by induction n with | zero => rw [Nat.add_zero, Nat.pow_zero, Nat.mul_one] | succ n ih => rw [Nat.add_succ, Nat.pow_succ, ih, Nat.pow_succ, mul_assoc] theorem pow_mul (a m n : Nat) : a ^ (m * n) = (a ^ m) ^ n := by induction n with | zero => rw [Nat.mul_zero, Nat.pow_zero, Nat.pow_zero] | succ n ih => rw [Nat.mul_succ, pow_add, ih, Nat.pow_succ] theorem pos_pow_of_pos {a : Nat} (n : Nat) (h : 0 < a) : 0 < a ^ n := Nat.pow_pos h /-! ## Primality (10-dimensions' predicate, moved by task LM17) -/ /-- Primality by trial division, decidable. -/ def isPrime (n : Nat) : Prop := 2 ≤ n ∧ ∀ d, d < n → 2 ≤ d → n % d ≠ 0 instance (n : Nat) : Decidable (isPrime n) := by unfold isPrime; exact inferInstance /-- Trial division up to `B` decides primality when `n < (B + 1)²`: a divisor `d ≥ 2` of `n` with `d > B` has a cofactor `q = n/d` with `2 ≤ q ≤ B`, itself a divisor. (From 14-entropy, moved by task LM22.) -/ theorem isPrime_of_bounded (n B : Nat) (h2 : 2 ≤ n) (hB : n < (B + 1) * (B + 1)) (hd : ∀ d, d < B + 1 → 2 ≤ d → n % d ≠ 0) : isPrime n := by refine ⟨h2, fun d hdn hd2 hmod => ?_⟩ have hd0 : 0 < d := Nat.lt_of_lt_of_le (Nat.zero_lt_succ 1) hd2 obtain ⟨q, hq⟩ := mod_spec d hd0 n rw [hmod, Nat.add_zero] at hq match Nat.lt_or_ge d (B + 1) with | .inl hlt => exact hd d hlt hd2 hmod | .inr hge => -- the cofactor `q`: `n = d q`, `q ≥ 2` (else `n = 0` or `n = d`), and `q ≤ B` (else `d q ≥ (B+1)²`) have hq2 : 2 ≤ q := by match q with | 0 => rw [Nat.mul_zero] at hq; exact absurd (hq ▸ h2) (Nat.not_succ_le_zero 1) | 1 => rw [Nat.mul_one] at hq; exact absurd (hq ▸ hdn) (Nat.lt_irrefl d) | q + 2 => exact Nat.le_add_left 2 q have hqB : q < B + 1 := by match Nat.lt_or_ge q (B + 1) with | .inl h => exact h | .inr hqge => have : (B + 1) * (B + 1) ≤ d * q := Nat.mul_le_mul hge hqge exact absurd (Nat.lt_of_lt_of_le hB this) (hq ▸ Nat.lt_irrefl n) have hq0 : 0 < q := Nat.lt_of_lt_of_le (Nat.zero_lt_succ 1) hq2 have hmodq : n % q = 0 := mod_unique hq0 (by rw [hq, Nat.mul_comm d q, Nat.add_zero]) exact hd q hqB hq2 hmodq end FRC.Nat /-! inlined: FrcCore/Pigeonhole.lean -/ /-! # FrcCore.Pigeonhole — a list of `n` distinct numbers in `[1, n]` is all of `[1, n]` The counting fact behind "the drive generates": its `p − 1` powers are distinct nonzero residues, and there are only `p − 1` of those. Lists of naturals with their own membership, no-duplicates and erase (Lean's `List` lemmas carry `propext`); everything by induction. No axioms. -/ namespace FRC namespace Pigeonhole /-- Membership, by recursion (decidable). -/ def mem (v : Nat) : List Nat → Prop | [] => False | a :: l => v = a ∨ mem v l def decMem (v : Nat) : (l : List Nat) → Decidable (mem v l) | [] => isFalse id | a :: l => match Nat.decEq v a, decMem v l with | isTrue h, _ => isTrue (Or.inl h) | isFalse _, isTrue h' => isTrue (Or.inr h') | isFalse h, isFalse h' => isFalse (fun e => match e with | Or.inl e => h e | Or.inr e => h' e) instance (v : Nat) (l : List Nat) : Decidable (mem v l) := decMem v l /-- No duplicates, by recursion. -/ def NoDup : List Nat → Prop | [] => True | a :: l => ¬ mem a l ∧ NoDup l /-- Remove the first occurrence of `v`. -/ def erase (v : Nat) : List Nat → List Nat | [] => [] | a :: l => if a = v then l else a :: erase v l theorem length_erase_of_mem {v : Nat} : ∀ {l : List Nat}, mem v l → (erase v l).length + 1 = l.length | [], h => absurd h id | a :: l, h => by show (if a = v then l else a :: erase v l).length + 1 = l.length + 1 exact match Nat.decEq a v with | isTrue e => by rw [ite_eq_left e] | isFalse e => by rw [ite_eq_right e] show (erase v l).length + 1 + 1 = l.length + 1 have hm : mem v l := match h with | Or.inl h' => absurd h'.symm e | Or.inr h' => h' rw [length_erase_of_mem hm] theorem mem_of_mem_erase {w v : Nat} : ∀ {l : List Nat}, mem w (erase v l) → mem w l | [], h => absurd h id | a :: l, h => by show w = a ∨ mem w l exact match Nat.decEq a v with | isTrue e => by rw [show erase v (a :: l) = l from ite_eq_left e] at h exact Or.inr h | isFalse e => by rw [show erase v (a :: l) = a :: erase v l from ite_eq_right e] at h exact match h with | Or.inl h' => Or.inl h' | Or.inr h' => Or.inr (mem_of_mem_erase h') theorem mem_erase_of_ne {w v : Nat} (hwv : w ≠ v) : ∀ {l : List Nat}, mem w l → mem w (erase v l) | [], h => absurd h id | a :: l, h => by exact match Nat.decEq a v with | isTrue e => by rw [show erase v (a :: l) = l from ite_eq_left e] exact match h with | Or.inl h' => absurd (h'.trans e) hwv | Or.inr h' => h' | isFalse e => by rw [show erase v (a :: l) = a :: erase v l from ite_eq_right e] exact match h with | Or.inl h' => Or.inl h' | Or.inr h' => Or.inr (mem_erase_of_ne hwv h') theorem nodup_erase (v : Nat) : ∀ {l : List Nat}, NoDup l → NoDup (erase v l) | [], _ => trivial | a :: l, ⟨ha, hl⟩ => by exact match Nat.decEq a v with | isTrue e => by rw [show erase v (a :: l) = l from ite_eq_left e]; exact hl | isFalse e => by rw [show erase v (a :: l) = a :: erase v l from ite_eq_right e] exact ⟨fun h => ha (mem_of_mem_erase h), nodup_erase v hl⟩ theorem not_mem_erase_self (v : Nat) : ∀ {l : List Nat}, NoDup l → ¬ mem v (erase v l) | [], _, h => h | a :: l, ⟨ha, hl⟩, h => by exact match Nat.decEq a v with | isTrue e => by rw [show erase v (a :: l) = l from ite_eq_left e] at h exact ha (e ▸ h) | isFalse e => by rw [show erase v (a :: l) = a :: erase v l from ite_eq_right e] at h exact match h with | Or.inl h' => e h'.symm | Or.inr h' => not_mem_erase_self v hl h' /-- The bound: a list of distinct numbers in `[1, n]` has at most `n` entries. -/ theorem length_le_of_nodup : ∀ (n : Nat) (l : List Nat), NoDup l → (∀ e, mem e l → 1 ≤ e ∧ e ≤ n) → l.length ≤ n | 0, [], _, _ => Nat.le_refl 0 | 0, a :: l, _, hb => absurd (hb a (Or.inl rfl)) (fun ⟨h1, h0⟩ => Nat.lt_irrefl 0 (Nat.lt_of_lt_of_le h1 h0)) | n + 1, l, hnd, hb => match (inferInstance : Decidable (mem (n + 1) l)) with | isTrue hm => have h1 : (erase (n + 1) l).length ≤ n := length_le_of_nodup n (erase (n + 1) l) (nodup_erase _ hnd) (fun e he => have hb' := hb e (mem_of_mem_erase he) ⟨hb'.1, match Nat.lt_or_ge e (n + 1) with | Or.inl hlt => Nat.le_of_lt_succ hlt | Or.inr hge => have : e = n + 1 := Nat.le_antisymm hb'.2 hge absurd (this ▸ he) (not_mem_erase_self (n + 1) hnd)⟩) by rw [← length_erase_of_mem hm]; exact Nat.succ_le_succ h1 | isFalse hm => Nat.le_succ_of_le (length_le_of_nodup n l hnd (fun e he => have hb' := hb e he ⟨hb'.1, match Nat.lt_or_ge e (n + 1) with | Or.inl hlt => Nat.le_of_lt_succ hlt | Or.inr hge => absurd he ((Nat.le_antisymm hb'.2 hge) ▸ hm)⟩)) /-- The pigeonhole: `n` distinct numbers in `[1, n]` are all of them. -/ theorem mem_of_nodup_of_length (n : Nat) (l : List Nat) (hnd : NoDup l) (hb : ∀ e, mem e l → 1 ≤ e ∧ e ≤ n) (hlen : l.length = n) (v : Nat) (hv1 : 1 ≤ v) (hvn : v ≤ n) : mem v l := match decMem v l with | isTrue h => h | isFalse h => have hnd' : NoDup (v :: l) := ⟨h, hnd⟩ have hb' : ∀ e, mem e (v :: l) → 1 ≤ e ∧ e ≤ n := fun e he => match he with | Or.inl e' => e' ▸ ⟨hv1, hvn⟩ | Or.inr e' => hb e e' have := length_le_of_nodup n (v :: l) hnd' hb' absurd (hlen ▸ this : n + 1 ≤ n) (Nat.not_succ_le_self n) /-- The same with the range `[0, n)`: a list of distinct numbers below `n` has at most `n` entries. -/ theorem length_le_of_nodup_lt : ∀ (n : Nat) (l : List Nat), NoDup l → (∀ e, mem e l → e < n) → l.length ≤ n | 0, [], _, _ => Nat.le_refl 0 | 0, a :: l, _, hb => absurd (hb a (Or.inl rfl)) (Nat.not_lt_zero a) | n + 1, l, hnd, hb => match decMem n l with | isTrue hm => have h1 : (erase n l).length ≤ n := length_le_of_nodup_lt n (erase n l) (nodup_erase _ hnd) (fun e he => match Nat.lt_or_ge e n with | Or.inl hlt => hlt | Or.inr hge => have : e = n := Nat.le_antisymm (Nat.le_of_lt_succ (hb e (mem_of_mem_erase he))) hge absurd (this ▸ he) (not_mem_erase_self n hnd)) by rw [← length_erase_of_mem hm]; exact Nat.succ_le_succ h1 | isFalse hm => Nat.le_succ_of_le (length_le_of_nodup_lt n l hnd (fun e he => match Nat.lt_or_ge e n with | Or.inl hlt => hlt | Or.inr hge => absurd he ((Nat.le_antisymm (Nat.le_of_lt_succ (hb e he)) hge) ▸ hm))) /-- `n` distinct numbers below `n` are all of them. -/ theorem mem_of_nodup_of_length_lt (n : Nat) (l : List Nat) (hnd : NoDup l) (hb : ∀ e, mem e l → e < n) (hlen : l.length = n) (v : Nat) (hv : v < n) : mem v l := match decMem v l with | isTrue h => h | isFalse h => have hb' : ∀ e, mem e (v :: l) → e < n := fun e he => match he with | Or.inl e' => e' ▸ hv | Or.inr e' => hb e e' have := length_le_of_nodup_lt n (v :: l) ⟨h, hnd⟩ hb' absurd (hlen ▸ this : n + 1 ≤ n) (Nat.not_succ_le_self n) end Pigeonhole end FRC /-! inlined: FrcCore/Shell.lean -/ /-! # FrcCore.Shell — the residues of a shell, from first principles `Shell p` is the set of residues mod `p`, carried by their canonical representatives `val < p` — no quotient type, so no `Quot.sound`; every identity below is an identity of representatives, decided by `Nat` arithmetic. The operations reduce by `%`, so `decide` computes on any concrete shell through the kernel's accelerated `Nat` arithmetic, and every theorem is checked to depend on no axiom. The ring laws are derived from `FrcCore.Nat`'s division algorithm (`mod_unique`); negation is characterised by `add_neg : a + -a = 0`, and everything about `-` follows from the uniqueness of additive inverses (`neg_unique`), never from `Nat` subtraction. Since the ledger migration (task LM17) it also holds `mul_mul_mul_comm` (from 14-entropy and 3-causality). -/ namespace FRC /-- A residue mod `p`: its representative and the bound. -/ structure Shell (p : Nat) where val : Nat lt : val < p /-- `Pos p`: the modulus is positive. Instances for literals `n + 1` are found automatically. -/ class Pos (p : Nat) : Prop where pos : 0 < p instance (n : Nat) : Pos (n + 1) := ⟨Nat.zero_lt_succ n⟩ namespace Shell variable {p : Nat} theorem ext {a b : Shell p} (h : a.val = b.val) : a = b := by cases a; cases b; cases h; rfl theorem val_injective {a b : Shell p} (h : a = b) : a.val = b.val := by cases h; rfl instance : DecidableEq (Shell p) := fun a b => if h : a.val = b.val then isTrue (ext h) else isFalse (fun e => h (val_injective e)) section ops variable [Pos p] /-- The residue of a natural number. -/ def ofNat (n : Nat) : Shell p := ⟨n % p, Nat.mod_lt n Pos.pos⟩ instance (n : Nat) : OfNat (Shell p) n := ⟨ofNat n⟩ instance : Add (Shell p) := ⟨fun a b => ofNat (a.val + b.val)⟩ instance : Mul (Shell p) := ⟨fun a b => ofNat (a.val * b.val)⟩ instance : Neg (Shell p) := ⟨fun a => ofNat (p - a.val)⟩ /-- Powers by structural recursion (`a ^ 0 = 1`, `a ^ (n+1) = a ^ n * a`). -/ def pow (a : Shell p) : Nat → Shell p | 0 => 1 | n + 1 => pow a n * a instance : Pow (Shell p) Nat := ⟨pow⟩ theorem hp : 0 < p := Pos.pos @[simp] theorem val_ofNat (n : Nat) : (ofNat n : Shell p).val = n % p := rfl theorem val_add (a b : Shell p) : (a + b).val = (a.val + b.val) % p := rfl theorem val_mul (a b : Shell p) : (a * b).val = (a.val * b.val) % p := rfl theorem val_neg (a : Shell p) : (-a).val = (p - a.val) % p := rfl theorem val_lit (n : Nat) : (OfNat.ofNat n : Shell p).val = n % p := rfl theorem val_zero : (0 : Shell p).val = 0 := rfl theorem val_one : (1 : Shell p).val = 1 % p := rfl theorem pow_zero (a : Shell p) : a ^ 0 = 1 := rfl theorem pow_succ (a : Shell p) (n : Nat) : a ^ (n + 1) = a ^ n * a := rfl theorem ofNat_val (a : Shell p) : ofNat a.val = a := ext (FRC.Nat.mod_eq_of_lt a.lt) theorem ofNat_mod (n : Nat) : (ofNat (n % p) : Shell p) = ofNat n := ext (FRC.Nat.mod_mod n p hp) /-! ### The additive laws -/ theorem add_comm (a b : Shell p) : a + b = b + a := ext (by rw [val_add, val_add, Nat.add_comm]) theorem add_assoc (a b c : Shell p) : a + b + c = a + (b + c) := ext (by rw [val_add, val_add, val_add, val_add, FRC.Nat.mod_add_mod _ _ _ hp, FRC.Nat.add_mod_mod _ _ _ hp, Nat.add_assoc]) theorem zero_add (a : Shell p) : 0 + a = a := ext (by rw [val_add, val_zero, Nat.zero_add]; exact FRC.Nat.mod_eq_of_lt a.lt) theorem add_zero (a : Shell p) : a + 0 = a := by rw [add_comm]; exact zero_add a theorem add_left_comm (a b c : Shell p) : a + (b + c) = b + (a + c) := by rw [← add_assoc, add_comm a b, add_assoc] theorem add_add_add_comm (a b c d : Shell p) : a + b + (c + d) = a + c + (b + d) := by rw [add_assoc, add_assoc, add_left_comm b] /-! ### The multiplicative laws -/ theorem mul_comm (a b : Shell p) : a * b = b * a := ext (by rw [val_mul, val_mul, Nat.mul_comm]) theorem mul_assoc (a b c : Shell p) : a * b * c = a * (b * c) := ext (by rw [val_mul, val_mul, val_mul, val_mul, FRC.Nat.mod_mul_mod _ _ _ hp, FRC.Nat.mul_mod_mod _ _ _ hp, FRC.Nat.mul_assoc]) theorem one_mul (a : Shell p) : 1 * a = a := ext (by rw [val_mul, val_one, FRC.Nat.mod_mul_mod _ _ _ hp, Nat.one_mul]; exact FRC.Nat.mod_eq_of_lt a.lt) theorem mul_one (a : Shell p) : a * 1 = a := by rw [mul_comm]; exact one_mul a theorem zero_mul (a : Shell p) : 0 * a = 0 := ext (by rw [val_mul, val_zero, Nat.zero_mul]; rfl) theorem mul_zero (a : Shell p) : a * 0 = 0 := by rw [mul_comm]; exact zero_mul a theorem mul_left_comm (a b c : Shell p) : a * (b * c) = b * (a * c) := by rw [← mul_assoc, mul_comm a b, mul_assoc] theorem left_distrib (a b c : Shell p) : a * (b + c) = a * b + a * c := ext (by rw [val_mul, val_add, val_add, val_mul, val_mul, FRC.Nat.mul_mod_mod _ _ _ hp, FRC.Nat.add_mod _ _ _ hp, FRC.Nat.mod_mod _ _ hp, FRC.Nat.mod_mod _ _ hp, ← FRC.Nat.add_mod _ _ _ hp, Nat.left_distrib]) theorem right_distrib (a b c : Shell p) : (a + b) * c = a * c + b * c := by rw [mul_comm, left_distrib, mul_comm c a, mul_comm c b] /-! ### Negation, characterised by `add_neg` -/ theorem add_neg (a : Shell p) : a + -a = 0 := ext (by rw [val_add, val_neg, FRC.Nat.add_mod_mod _ _ _ hp, FRC.Nat.add_sub_of_le (Nat.le_of_lt a.lt), FRC.Nat.mod_self p hp]; rfl) theorem neg_add (a : Shell p) : -a + a = 0 := by rw [add_comm]; exact add_neg a /-- Additive inverses are unique. -/ theorem neg_unique {a x y : Shell p} (hx : a + x = 0) (hy : a + y = 0) : x = y := by calc x = x + 0 := (add_zero x).symm _ = x + (a + y) := by rw [hy] _ = (x + a) + y := (add_assoc _ _ _).symm _ = (a + x) + y := by rw [add_comm x a] _ = 0 + y := by rw [hx] _ = y := zero_add y theorem neg_eq_of_add_eq_zero {a b : Shell p} (h : a + b = 0) : -a = b := neg_unique (add_neg a) h theorem neg_neg (a : Shell p) : - -a = a := neg_eq_of_add_eq_zero (neg_add a) theorem neg_zero : (-0 : Shell p) = 0 := neg_eq_of_add_eq_zero (add_zero 0) theorem neg_mul (a b : Shell p) : -(a * b) = -a * b := neg_eq_of_add_eq_zero (by rw [← right_distrib, add_neg, zero_mul]) theorem mul_neg (a b : Shell p) : -(a * b) = a * -b := by rw [mul_comm, neg_mul, mul_comm] theorem neg_mul_neg (a b : Shell p) : -a * -b = a * b := by rw [← neg_mul, ← mul_neg, neg_neg] theorem neg_add_rev (a b : Shell p) : -(a + b) = -a + -b := neg_eq_of_add_eq_zero (by rw [add_assoc, add_left_comm b, ← add_assoc, add_neg, zero_add, add_neg]) theorem add_right_cancel {a b c : Shell p} (h : a + c = b + c) : a = b := by have : a + c + -c = b + c + -c := by rw [h] rw [add_assoc, add_neg, add_zero, add_assoc, add_neg, add_zero] at this exact this theorem eq_neg_of_add_eq_zero {a b : Shell p} (h : a + b = 0) : a = -b := by rw [← neg_neg a, neg_eq_of_add_eq_zero h] theorem neg_one_mul (a : Shell p) : -1 * a = -a := by rw [← neg_mul, one_mul] /-! ### Powers -/ theorem pow_one (a : Shell p) : a ^ 1 = a := by rw [pow_succ, pow_zero, one_mul] theorem one_pow (n : Nat) : (1 : Shell p) ^ n = 1 := by induction n with | zero => rfl | succ n ih => rw [pow_succ, ih, mul_one] theorem pow_add (a : Shell p) (m n : Nat) : a ^ (m + n) = a ^ m * a ^ n := by induction n with | zero => rw [Nat.add_zero, pow_zero, mul_one] | succ n ih => rw [Nat.add_succ, pow_succ, ih, pow_succ, mul_assoc] theorem pow_mul (a : Shell p) (m n : Nat) : a ^ (m * n) = (a ^ m) ^ n := by induction n with | zero => rw [Nat.mul_zero, pow_zero, pow_zero] | succ n ih => rw [Nat.mul_succ, pow_add, ih, pow_succ] theorem pow_mul_comm (a : Shell p) (m n : Nat) : (a ^ m) ^ n = (a ^ n) ^ m := by rw [← pow_mul, Nat.mul_comm, pow_mul] theorem mul_pow (a b : Shell p) (n : Nat) : (a * b) ^ n = a ^ n * b ^ n := by induction n with | zero => rw [pow_zero, pow_zero, pow_zero, mul_one] | succ n ih => rw [pow_succ, pow_succ, pow_succ, ih, mul_assoc, mul_assoc, mul_left_comm (b ^ n) a b] theorem pow_two (a : Shell p) : a ^ 2 = a * a := by rw [pow_succ, pow_one] theorem neg_pow_two (a : Shell p) : (-a) ^ 2 = a ^ 2 := by rw [pow_two, pow_two, neg_mul_neg] /-- `(-1)^n` by the parity of `n`. -/ theorem neg_one_pow (n : Nat) : (-1 : Shell p) ^ n = if n % 2 = 0 then 1 else -1 := by induction n with | zero => rfl | succ n ih => rw [pow_succ, ih] exact match Nat.decEq (n % 2) 0 with | .isTrue h => by rw [ite_eq_left h, one_mul] have : (n + 1) % 2 = 1 := by rw [← FRC.Nat.mod_add_mod _ _ _ (Nat.zero_lt_succ 1), h] rw [ite_eq_right (by rw [this]; exact fun e => Nat.noConfusion e)] | .isFalse h => by rw [ite_eq_right h, neg_mul_neg, one_mul] have h1 : n % 2 = 1 := by have := Nat.mod_lt n (Nat.zero_lt_succ 1) exact match n % 2, this, h with | 0, _, h => absurd rfl h | 1, _, _ => rfl | k + 2, hk, _ => absurd hk (Nat.not_lt_of_le (Nat.le_add_left 2 k)) have : (n + 1) % 2 = 0 := by rw [← FRC.Nat.mod_add_mod _ _ _ (Nat.zero_lt_succ 1), h1] rw [ite_eq_left this] /-- `a b (c d) = a c (b d)` on every shell (14-entropy and 3-causality's lemma, moved by task LM17). -/ theorem mul_mul_mul_comm (a b c d : Shell p) : a * b * (c * d) = a * c * (b * d) := by rw [mul_assoc, mul_left_comm b c d, ← mul_assoc] end ops end Shell end FRC /-! inlined: FrcCore/Series.lean -/ /-! # FrcCore.Series — bounded search, finite sums and products on the shell (the base theme, task LM22) What every theme above needs and no frame provides: bounded quantifiers decided by search, without `propext` (`decExistsLT`, `decForallLT`); sums `Σ_{l isFalse (fun ⟨m, hm, _⟩ => Nat.not_lt_zero m hm) | n + 1 => match decExistsLT P n with | isTrue h => isTrue (match h with | ⟨m, hm, hp⟩ => ⟨m, Nat.lt_succ_of_lt hm, hp⟩) | isFalse hno => if h : P n then isTrue ⟨n, Nat.lt_succ_self n, h⟩ else isFalse (fun ⟨m, hm, hp⟩ => match Nat.lt_or_ge m n with | .inl hlt => hno ⟨m, hlt, hp⟩ | .inr hge => h ((Nat.le_antisymm (Nat.le_of_lt_succ hm) hge) ▸ hp)) /-- `∀ m < n, P m`, decided by recursion on `n` — Lean's own instance carries `propext`; this one nothing. -/ def decForallLT (P : Nat → Prop) [DecidablePred P] : (n : Nat) → Decidable (∀ m, m < n → P m) | 0 => isTrue (fun m hm => absurd hm (Nat.not_lt_zero m)) | n + 1 => match decForallLT P n with | isFalse h => isFalse (fun hall => h (fun m hm => hall m (Nat.lt_succ_of_lt hm))) | isTrue h => if hn : P n then isTrue (fun m hm => match Nat.lt_or_ge m n with | .inl hlt => h m hlt | .inr hge => (Nat.le_antisymm (Nat.le_of_lt_succ hm) hge) ▸ hn) else isFalse (fun hall => hn (hall n (Nat.lt_succ_self n))) /-! ## Finite sums -/ /-- `sumRange f n = f 0 + f 1 + ⋯ + f (n−1)`. -/ def sumRange (f : Nat → Shell p) : Nat → Shell p | 0 => 0 | n + 1 => sumRange f n + f n theorem sumRange_zero (f : Nat → Shell p) : sumRange f 0 = 0 := rfl theorem sumRange_succ (f : Nat → Shell p) (n : Nat) : sumRange f (n + 1) = sumRange f n + f n := rfl theorem sum_congr {f h : Nat → Shell p} (n : Nat) (e : ∀ l, l < n → f l = h l) : sumRange f n = sumRange h n := by induction n with | zero => rfl | succ n ih => rw [sumRange_succ, sumRange_succ, ih (fun l hl => e l (Nat.lt_succ_of_lt hl)), e n (Nat.lt_succ_self n)] theorem sum_add (f h : Nat → Shell p) (n : Nat) : sumRange (fun l => f l + h l) n = sumRange f n + sumRange h n := by induction n with | zero => rw [sumRange_zero, sumRange_zero, sumRange_zero, add_zero] | succ n ih => rw [sumRange_succ, sumRange_succ, sumRange_succ, ih, add_add_add_comm] theorem sum_mul_right (f : Nat → Shell p) (c : Shell p) (n : Nat) : sumRange (fun l => f l * c) n = sumRange f n * c := by induction n with | zero => rw [sumRange_zero, sumRange_zero, zero_mul] | succ n ih => rw [sumRange_succ, sumRange_succ, ih, right_distrib] theorem sum_mul_left (f : Nat → Shell p) (c : Shell p) (n : Nat) : sumRange (fun l => c * f l) n = c * sumRange f n := by induction n with | zero => rw [sumRange_zero, sumRange_zero, mul_zero] | succ n ih => rw [sumRange_succ, sumRange_succ, ih, left_distrib] theorem sum_neg (f : Nat → Shell p) (n : Nat) : sumRange (fun l => -(f l)) n = -(sumRange f n) := by induction n with | zero => rw [sumRange_zero, sumRange_zero, neg_zero] | succ n ih => rw [sumRange_succ, sumRange_succ, ih, neg_add_rev] theorem sum_const (c : Shell p) (n : Nat) : sumRange (fun _ => c) n = ofNat n * c := by induction n with | zero => rw [sumRange_zero]; exact (zero_mul c).symm | succ n ih => rw [sumRange_succ, ih] have : (ofNat (n + 1) : Shell p) = ofNat n + 1 := ext (by rw [val_ofNat, val_add, val_ofNat, val_one, FRC.Nat.mod_add_mod _ _ _ hp, FRC.Nat.add_mod_mod _ _ _ hp]) rw [this, right_distrib, one_mul] theorem sum_zero {f : Nat → Shell p} (n : Nat) (h : ∀ l, l < n → f l = 0) : sumRange f n = 0 := by induction n with | zero => rfl | succ n ih => rw [sumRange_succ, ih (fun l hl => h l (Nat.lt_succ_of_lt hl)), h n (Nat.lt_succ_self n), add_zero] /-- A sum with a single nonzero term. -/ theorem sum_eq_single {f : Nat → Shell p} {l₀ : Nat} : ∀ {n : Nat}, l₀ < n → (∀ l, l < n → l ≠ l₀ → f l = 0) → sumRange f n = f l₀ | 0, h, _ => absurd h (Nat.not_lt_zero _) | n + 1, hl₀, h => by rw [sumRange_succ] exact match Nat.decEq l₀ n with | isTrue e => by rw [sum_zero n (fun l hl => h l (Nat.lt_succ_of_lt hl) (fun e' => absurd hl (by rw [e', e]; exact Nat.lt_irrefl n))), zero_add, e] | isFalse e => by rw [sum_eq_single (Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hl₀) (fun e' => e e')) (fun l hl hne => h l (Nat.lt_succ_of_lt hl) hne), h n (Nat.lt_succ_self n) (fun e' => e e'.symm), add_zero] /-- The telescoping geometric sum: `(Σ_{l x ^ l) n * (x + -1) = x ^ n + -1 := by induction n with | zero => rw [sumRange_zero, zero_mul, pow_zero, add_neg] | succ n ih => rw [sumRange_succ, right_distrib, ih, left_distrib, ← mul_neg, mul_one, ← pow_succ] rw [add_add_add_comm, add_comm (x ^ n) (x ^ (n + 1)), add_comm (-1) (-(x ^ n)), add_assoc, ← add_assoc (x ^ n), add_neg, zero_add] /-- `Σ_{l f (l + 1)) n | 0 => by rw [sumRange_succ, sumRange_zero, sumRange_zero, zero_add, add_zero] | n + 1 => by rw [sumRange_succ, sumRange_succ' f n, sumRange_succ, add_assoc] /-! ## Sums over lists, permutation invariance (the reindexing `j ↦ u·j` of 2:F5) -/ /-- The sum of `F` over a list of indices. -/ def sumList (F : Nat → Shell p) : List Nat → Shell p | [] => 0 | a :: l => F a + sumList F l /-- `[n−1, …, 0]`. -/ def listRange : Nat → List Nat | 0 => [] | n + 1 => n :: listRange n /-- `[σ (n−1), …, σ 0]`. -/ def imageList (σ : Nat → Nat) : Nat → List Nat | 0 => [] | n + 1 => σ n :: imageList σ n theorem sumList_imageList (F : Nat → Shell p) (σ : Nat → Nat) (n : Nat) : sumList F (imageList σ n) = sumRange (fun j => F (σ j)) n := by induction n with | zero => rfl | succ n ih => show F (σ n) + sumList F (imageList σ n) = sumRange (fun j => F (σ j)) n + F (σ n); rw [ih, add_comm] theorem sumList_erase (F : Nat → Shell p) {v : Nat} : ∀ {l : List Nat}, Pigeonhole.mem v l → sumList F l = F v + sumList F (Pigeonhole.erase v l) | [], h => absurd h id | a :: l, h => by exact match Nat.decEq a v with | isTrue e => by rw [show Pigeonhole.erase v (a :: l) = l from ite_eq_left e, e]; rfl | isFalse e => by rw [show Pigeonhole.erase v (a :: l) = a :: Pigeonhole.erase v l from ite_eq_right e] have hm : Pigeonhole.mem v l := match h with | Or.inl h' => absurd h'.symm e | Or.inr h' => h' show F a + sumList F l = F v + (F a + sumList F (Pigeonhole.erase v l)) rw [sumList_erase F hm, add_left_comm] theorem imageList_length (σ : Nat → Nat) (n : Nat) : (imageList σ n).length = n := by induction n with | zero => rfl | succ n ih => show (imageList σ n).length + 1 = n + 1; rw [ih] theorem mem_imageList {σ : Nat → Nat} {v : Nat} : ∀ {n : Nat}, Pigeonhole.mem v (imageList σ n) → ∃ j, j < n ∧ σ j = v | 0, h => absurd h id | n + 1, h => match h with | Or.inl e => ⟨n, Nat.lt_succ_self n, e.symm⟩ | Or.inr h' => match mem_imageList h' with | ⟨j, hj, e⟩ => ⟨j, Nat.lt_succ_of_lt hj, e⟩ theorem imageList_nodup {σ : Nat → Nat} {n : Nat} (hinj : ∀ i j, i < n → j < n → σ i = σ j → i = j) : ∀ {m : Nat}, m ≤ n → Pigeonhole.NoDup (imageList σ m) | 0, _ => trivial | m + 1, hm => ⟨fun h => match mem_imageList h with | ⟨j, hj, e⟩ => Nat.lt_irrefl j (hinj j m (Nat.lt_of_lt_of_le hj (Nat.le_of_lt hm)) hm e ▸ hj), imageList_nodup hinj (Nat.le_of_lt hm)⟩ /-- A sum over any list of `n` distinct indices below `n` is the sum over `0, …, n−1`. -/ theorem sumList_eq_sumRange (F : Nat → Shell p) : ∀ (n : Nat) (l : List Nat), Pigeonhole.NoDup l → (∀ e, Pigeonhole.mem e l → e < n) → l.length = n → sumList F l = sumRange F n | 0, [], _, _, _ => rfl | 0, a :: l, _, hb, _ => absurd (hb a (Or.inl rfl)) (Nat.not_lt_zero a) | n + 1, l, hnd, hb, hlen => by have hm : Pigeonhole.mem n l := Pigeonhole.mem_of_nodup_of_length_lt (n + 1) l hnd hb hlen n (Nat.lt_succ_self n) rw [sumList_erase F hm, sumRange_succ, add_comm] have hb' : ∀ e, Pigeonhole.mem e (Pigeonhole.erase n l) → e < n := fun e he => match Nat.lt_or_ge e n with | Or.inl hlt => hlt | Or.inr hge => have : e = n := Nat.le_antisymm (Nat.le_of_lt_succ (hb e (Pigeonhole.mem_of_mem_erase he))) hge absurd (this ▸ he) (Pigeonhole.not_mem_erase_self n hnd) have hlen' : (Pigeonhole.erase n l).length = n := by have := Pigeonhole.length_erase_of_mem hm; rw [hlen] at this; exact Nat.succ.inj this rw [sumList_eq_sumRange F n (Pigeonhole.erase n l) (Pigeonhole.nodup_erase n hnd) hb' hlen'] /-- Permutation invariance: for `σ` injective on `[0, n)` with values below `n`, `Σ_{j F (σ j)) n = sumRange F n := by rw [← sumList_imageList] exact sumList_eq_sumRange F n (imageList σ n) (imageList_nodup hinj (Nat.le_refl n)) (fun e he => match mem_imageList he with | ⟨j, hj, e'⟩ => e' ▸ hlt j hj) (imageList_length σ n) /-! ## Products over `[0, n)`, invariant under a permutation (the products of `Sum.lean`'s sums) -/ /-- `Π_{j 1 | n + 1 => prodRange f n * f n theorem prodRange_zero (f : Nat → Shell p) : prodRange f 0 = 1 := rfl theorem prodRange_succ (f : Nat → Shell p) (n : Nat) : prodRange f (n + 1) = prodRange f n * f n := rfl theorem prodRange_congr {f h : Nat → Shell p} : ∀ n, (∀ j, j < n → f j = h j) → prodRange f n = prodRange h n | 0, _ => rfl | n + 1, e => by rw [prodRange_succ, prodRange_succ, prodRange_congr n (fun j hj => e j (Nat.lt_succ_of_lt hj)), e n (Nat.lt_succ_self n)] /-- A common factor leaves the product as its power: `Π_{j a * G j) n = a ^ n * prodRange G n | 0 => (one_mul 1).symm | n + 1 => by rw [prodRange_succ, prodRange_succ, prodRange_mul_left a G n, pow_succ, mul_mul_mul_comm] /-- The product of `F` over a list of indices. -/ def prodList (F : Nat → Shell p) : List Nat → Shell p | [] => 1 | a :: l => F a * prodList F l theorem prodList_imageList (F : Nat → Shell p) (σ : Nat → Nat) (n : Nat) : prodList F (imageList σ n) = prodRange (fun j => F (σ j)) n := by induction n with | zero => rfl | succ n ih => show F (σ n) * prodList F (imageList σ n) = prodRange (fun j => F (σ j)) n * F (σ n); rw [ih, mul_comm] theorem prodList_erase (F : Nat → Shell p) {v : Nat} : ∀ {l : List Nat}, Pigeonhole.mem v l → prodList F l = F v * prodList F (Pigeonhole.erase v l) | [], h => absurd h id | a :: l, h => by exact match Nat.decEq a v with | isTrue e => by rw [show Pigeonhole.erase v (a :: l) = l from ite_eq_left e, e]; rfl | isFalse e => by rw [show Pigeonhole.erase v (a :: l) = a :: Pigeonhole.erase v l from ite_eq_right e] have hm : Pigeonhole.mem v l := match h with | Or.inl h' => absurd h'.symm e | Or.inr h' => h' show F a * prodList F l = F v * (F a * prodList F (Pigeonhole.erase v l)) rw [prodList_erase F hm, mul_left_comm] /-- A product over any list of `n` distinct indices below `n` is the product over `0, …, n−1`. -/ theorem prodList_eq_prodRange (F : Nat → Shell p) : ∀ (n : Nat) (l : List Nat), Pigeonhole.NoDup l → (∀ e, Pigeonhole.mem e l → e < n) → l.length = n → prodList F l = prodRange F n | 0, [], _, _, _ => rfl | 0, a :: l, _, hb, _ => absurd (hb a (Or.inl rfl)) (Nat.not_lt_zero a) | n + 1, l, hnd, hb, hlen => by have hm : Pigeonhole.mem n l := Pigeonhole.mem_of_nodup_of_length_lt (n + 1) l hnd hb hlen n (Nat.lt_succ_self n) rw [prodList_erase F hm, prodRange_succ, mul_comm] have hb' : ∀ e, Pigeonhole.mem e (Pigeonhole.erase n l) → e < n := fun e he => match Nat.lt_or_ge e n with | Or.inl hlt => hlt | Or.inr hge => have : e = n := Nat.le_antisymm (Nat.le_of_lt_succ (hb e (Pigeonhole.mem_of_mem_erase he))) hge absurd (this ▸ he) (Pigeonhole.not_mem_erase_self n hnd) have hlen' : (Pigeonhole.erase n l).length = n := by have := Pigeonhole.length_erase_of_mem hm; rw [hlen] at this; exact Nat.succ.inj this rw [prodList_eq_prodRange F n (Pigeonhole.erase n l) (Pigeonhole.nodup_erase n hnd) hb' hlen'] /-- Permutation invariance: for `σ` injective on `[0, n)` with values below `n`, `Π_{j F (σ j)) n = prodRange F n := by rw [← prodList_imageList] exact prodList_eq_prodRange F n (imageList σ n) (imageList_nodup hinj (Nat.le_refl n)) (fun e he => match mem_imageList he with | ⟨j, hj, e'⟩ => e' ▸ hlt j hj) (imageList_length σ n) end Shell namespace Logic /-- 5:C2, 29:C10 (Proposition mirror) — a part with fewer records than the frame has elements holds no injective representation of the frame's domain: no `f : [0, N) → [0, R)` is injective when `R < N`. In the base since task LM23 (from `Theme/Logic.lean`, under its old name), so that the foundation's A4 (Observation; the bounded observer, A5 at task LM23) stands on it. -/ theorem no_mirror {N R : Nat} (hR : R < N) (f : Nat → Nat) (hf : ∀ i, i < N → f i < R) (hinj : ∀ i j, i < N → j < N → f i = f j → i = j) : False := have hnd := FRC.Shell.imageList_nodup hinj (Nat.le_refl N) have hlen := FRC.Shell.imageList_length f N have hb : ∀ e, Pigeonhole.mem e (FRC.Shell.imageList f N) → e < R := fun _ he => match FRC.Shell.mem_imageList he with | ⟨j, hj, ej⟩ => ej ▸ hf j hj have := Pigeonhole.length_le_of_nodup_lt R _ hnd hb Nat.lt_irrefl N (Nat.lt_of_le_of_lt (hlen ▸ this) hR) end Logic end FRC /-! inlined: FrcCore/FrameCore.lean -/ /-! # FrcCore.FrameCore — the frame `(τ; 0, 1, g)` and the Euclidean datum, from first principles (the frame theme) The shell of capacity `κ` has modulus `p = 4κ + 1`; its frame carries the drive `g` (00:A6, 00:A12, 00:C1; labels as of 9 October 2026). One decidable predicate states what the frame's generator is: `IsPrimitive g n` (`g^n = 1`, no positive power below `n` is `1`). That `g` then *generates* — every nonzero residue is a power of `g` (`Generates g n`, also decidable) — is proved by the pigeonhole (`FrcCore.Pigeonhole`): the `n` powers are distinct nonzero residues and there are `n` of those. Primality of `p` is neither assumed nor used here; the classical equivalence (a frame on `p = 4κ + 1` exists iff `p` is prime) is `FrcBridge/Foundation.lean`'s `frame_iff_isPrime` (task LM23). From primitivity alone: inverses (`exists_inv`), no zero divisors (`mul_eq_zero`), the square roots of one (`sq_eq_one`), the half-period `g^{2κ} = −1` (2:D1, 00:C1), the quarter-turn `i = −g^κ` with `i² = −1` (1:B3, 2:D2), its orientation classes under `g ↦ g^u` (2:D5), the Euler identity `(g^i)^{i·2κ} = (−1)^i` (2:D6, 00:C14), `2π ≡ −1`, and `2 ≠ 0` with `2s = 0 ⇒ s = 0` (1:Z1). No axioms. Split from `Frame.lean` by the ledger migration (task LM24), every name unchanged, so that a theme needing the frame alone does not carry the frame's arithmetic; `Frame.lean` imports this file and keeps the rest. -/ namespace FRC namespace Shell variable {p : Nat} [Pos p] /-- 00:A12 — the drive generator is primitive of order `n`: `g^n = 1` and `g^l ≠ 1` for `0 < l < n`. -/ def IsPrimitive (g : Shell p) (n : Nat) : Prop := g ^ n = 1 ∧ ∀ l, l < n → 0 < l → g ^ l ≠ 1 instance (g : Shell p) (n : Nat) : Decidable (IsPrimitive g n) := by unfold IsPrimitive; exact inferInstance /-- 00:A12 — the drive generates the shell: every nonzero residue `v < p` is `g^m` for some `m < n`. -/ def Generates (g : Shell p) (n : Nat) : Prop := ∀ v, v < p → 0 < v → ∃ m, m < n ∧ (g ^ m).val = v instance (g : Shell p) (n : Nat) : Decidable (Generates g n) := by unfold Generates have : ∀ v, Decidable (∃ m, m < n ∧ (g ^ m).val = v) := fun v => decExistsLT (fun m => (g ^ m).val = v) n exact inferInstance /-- 00:C1 — the frame `(τ; 0, 1, g)` on the shell of capacity `κ`: `p = 4κ + 1`, `κ` positive, and the drive `g` a primitive generator of the `p − 1` nonzero residues. -/ structure Frame (p : Nat) [Pos p] (κ : Nat) (g : Shell p) : Prop where cap : p = 4 * κ + 1 cap_pos : 0 < κ prim : IsPrimitive g (p - 1) instance instDecForallLT (P : Nat → Prop) [DecidablePred P] (n : Nat) : Decidable (∀ m, m < n → P m) := decForallLT P n /-- `∀ x : Shell p, P x`, decided through the representatives. -/ instance instDecForallShell {p : Nat} [Pos p] (P : Shell p → Prop) [DecidablePred P] : Decidable (∀ x, P x) := match decForallLT (fun v => P (ofNat v)) p with | isTrue h => isTrue (fun x => ofNat_val x ▸ h x.val x.lt) | isFalse h => isFalse (fun hall => h (fun v _ => hall (ofNat v))) namespace Frame variable {κ : Nat} {g : Shell p} /-- A residue has at most one inverse (moved here from `Orbit.lean` by task LM25, name unchanged). -/ theorem inv_unique {x x' y : Shell p} (h : x * y = 1) (h' : x' * y = 1) : x = x' := by calc x = x * (x' * y) := by rw [h', mul_one] _ = x' * (x * y) := mul_left_comm _ _ _ _ = x' := by rw [h, mul_one] theorem n_eq (F : Frame p κ g) : p - 1 = 4 * κ := by rw [F.cap]; rfl theorem n_pos (F : Frame p κ g) : 0 < p - 1 := by rw [F.n_eq]; exact Nat.mul_pos (Nat.zero_lt_succ 3) F.cap_pos theorem one_lt_p (F : Frame p κ g) : 1 < p := by rw [F.cap]; exact Nat.succ_lt_succ (Nat.mul_pos (Nat.zero_lt_succ 3) F.cap_pos) theorem one_ne_zero (F : Frame p κ g) : (1 : Shell p) ≠ 0 := fun h => by have := val_injective h rw [val_one, val_zero, FRC.Nat.mod_eq_of_lt F.one_lt_p] at this exact Nat.noConfusion this theorem pow_n (F : Frame p κ g) : g ^ (p - 1) = 1 := F.prim.1 /-- Powers of the drive are periodic with period `p − 1`. -/ theorem pow_mod (F : Frame p κ g) (l : Nat) : g ^ l = g ^ (l % (p - 1)) := by match FRC.Nat.mod_spec (p - 1) F.n_pos l with | ⟨q, hq⟩ => calc g ^ l = g ^ ((p - 1) * q + l % (p - 1)) := by rw [← hq] _ = (g ^ (p - 1)) ^ q * g ^ (l % (p - 1)) := by rw [pow_add, pow_mul] _ = g ^ (l % (p - 1)) := by rw [F.pow_n, one_pow, one_mul] theorem pow_eq_one_of_mod (F : Frame p κ g) {l : Nat} (h : l % (p - 1) = 0) : g ^ l = 1 := by rw [F.pow_mod, h, pow_zero] theorem mod_eq_zero_of_pow_eq_one (F : Frame p κ g) {l : Nat} (h : g ^ l = 1) : l % (p - 1) = 0 := by rw [F.pow_mod] at h exact match Nat.decEq (l % (p - 1)) 0 with | .isTrue h0 => h0 | .isFalse h0 => absurd h (F.prim.2 _ (Nat.mod_lt l F.n_pos) (Nat.pos_of_ne_zero h0)) theorem pow_inj (F : Frame p κ g) {i j : Nat} (hi : i < p - 1) (hj : j < p - 1) (h : g ^ i = g ^ j) : i = j := by have key : ∀ {i j : Nat}, i ≤ j → j < p - 1 → g ^ i = g ^ j → i = j := by intro i j hij hj h have hji : j - i < p - 1 := Nat.lt_of_le_of_lt (Nat.sub_le j i) hj have e : g ^ j = g ^ i * g ^ (j - i) := by rw [← pow_add, FRC.Nat.add_sub_of_le hij] have hinv : g ^ i * g ^ (p - 1 - i) = 1 := by rw [← pow_add, FRC.Nat.add_sub_of_le (Nat.le_of_lt (Nat.lt_of_le_of_lt hij hj)), F.pow_n] have h1 : g ^ (j - i) = 1 := by calc g ^ (j - i) = 1 * g ^ (j - i) := (one_mul _).symm _ = g ^ (p - 1 - i) * g ^ i * g ^ (j - i) := by rw [mul_comm (g ^ (p - 1 - i)), hinv] _ = g ^ (p - 1 - i) * g ^ j := by rw [mul_assoc, ← e] _ = g ^ (p - 1 - i) * g ^ i := by rw [h] _ = 1 := by rw [mul_comm, hinv] have h2 := F.mod_eq_zero_of_pow_eq_one h1 rw [FRC.Nat.mod_eq_of_lt hji] at h2 have : j = i + (j - i) := (FRC.Nat.add_sub_of_le hij).symm rw [h2, Nat.add_zero] at this exact this.symm exact match Nat.lt_or_ge i j with | .inl hlt => key (Nat.le_of_lt hlt) hj h | .inr hge => (key hge hi h.symm).symm theorem g_ne_zero (F : Frame p κ g) : g ≠ 0 := fun h0 => by have hn := F.pow_n have : p - 1 = (p - 2) + 1 := by have := F.one_lt_p match p, this with | k + 2, _ => rfl rw [this, pow_succ, h0, mul_zero] at hn exact F.one_ne_zero hn.symm /-- No power of the drive is zero: `g^m · g^{(n−1)m} = g^{nm} = 1`. -/ theorem pow_ne_zero (F : Frame p κ g) (m : Nat) : g ^ m ≠ 0 := fun h0 => by have hn := F.n_pos have e : m + (p - 1 - 1) * m = (p - 1) * m := by calc m + (p - 1 - 1) * m = 1 * m + (p - 1 - 1) * m := by rw [Nat.one_mul] _ = (1 + (p - 1 - 1)) * m := (FRC.Nat.add_mul _ _ _).symm _ = (p - 1) * m := by rw [FRC.Nat.add_sub_of_le hn] have : g ^ m * g ^ ((p - 1 - 1) * m) = 1 := by rw [← pow_add, e, pow_mul, F.pow_n, one_pow] rw [h0, zero_mul] at this exact F.one_ne_zero this.symm /-- The representatives of `g^0, …, g^{n−1}`, as a list (latest first). -/ def powList (g : Shell p) : Nat → List Nat | 0 => [] | m + 1 => (g ^ m).val :: powList g m theorem powList_length (g : Shell p) (n : Nat) : (powList g n).length = n := by induction n with | zero => rfl | succ n ih => show (powList g n).length + 1 = n + 1; rw [ih] theorem mem_powList {g : Shell p} {v : Nat} : ∀ {n : Nat}, Pigeonhole.mem v (powList g n) → ∃ m, m < n ∧ (g ^ m).val = v | 0, h => absurd h id | n + 1, h => match h with | Or.inl e => ⟨n, Nat.lt_succ_self n, e.symm⟩ | Or.inr h' => match mem_powList h' with | ⟨m, hm, e⟩ => ⟨m, Nat.lt_succ_of_lt hm, e⟩ theorem powList_nodup (F : Frame p κ g) : ∀ {n : Nat}, n ≤ p - 1 → Pigeonhole.NoDup (powList g n) | 0, _ => trivial | n + 1, hn => ⟨fun h => match mem_powList h with | ⟨m, hm, e⟩ => have : m = n := F.pow_inj (Nat.lt_trans hm hn) hn (ext e) Nat.lt_irrefl n (this ▸ hm), powList_nodup F (Nat.le_of_lt hn)⟩ /-- 00:A12 — the drive generates: every nonzero residue is a power `g^m`, `m < p − 1` (the pigeonhole). -/ theorem generates (F : Frame p κ g) : Generates g (p - 1) := by intro v hv hv0 have hb : ∀ e, Pigeonhole.mem e (powList g (p - 1)) → 1 ≤ e ∧ e ≤ p - 1 := fun e he => match mem_powList he with | ⟨m, _, hm⟩ => ⟨Nat.pos_of_ne_zero (fun h0 => F.pow_ne_zero m (ext (by rw [hm, h0]; rfl))), by rw [← hm]; exact Nat.le_of_lt_succ (Nat.lt_of_lt_of_le (g ^ m).lt (Nat.le_of_eq (FRC.Nat.sub_add_cancel Pos.pos).symm))⟩ exact mem_powList (Pigeonhole.mem_of_nodup_of_length (p - 1) (powList g (p - 1)) (F.powList_nodup (Nat.le_refl _)) hb (powList_length g (p - 1)) v hv0 (Nat.le_of_lt_succ (Nat.lt_of_lt_of_le hv (Nat.le_of_eq (FRC.Nat.sub_add_cancel Pos.pos).symm)))) /-- Every nonzero residue is a power of the drive, on residues. -/ theorem eq_pow_of_ne_zero (F : Frame p κ g) {x : Shell p} (hx : x ≠ 0) : ∃ m, m < p - 1 ∧ g ^ m = x := by have hv : 0 < x.val := Nat.pos_of_ne_zero (fun h => hx (ext h)) match F.generates x.val x.lt hv with | ⟨m, hm, e⟩ => exact ⟨m, hm, ext e⟩ theorem exists_inv (F : Frame p κ g) {x : Shell p} (hx : x ≠ 0) : ∃ y, x * y = 1 := by match F.eq_pow_of_ne_zero hx with | ⟨m, hm, e⟩ => refine ⟨g ^ (p - 1 - m), ?_⟩ rw [← e, ← pow_add, FRC.Nat.add_sub_of_le (Nat.le_of_lt hm), F.pow_n] theorem mul_eq_zero (F : Frame p κ g) {a b : Shell p} (h : a * b = 0) : a = 0 ∨ b = 0 := match Shell.instDecidableEq a 0 with | .isTrue ha => .inl ha | .isFalse ha => .inr (by match F.exists_inv ha with | ⟨y, hy⟩ => calc b = 1 * b := (one_mul b).symm _ = y * a * b := by rw [mul_comm y a, hy] _ = y * (a * b) := mul_assoc _ _ _ _ = 0 := by rw [h, mul_zero]) theorem mul_ne_zero (F : Frame p κ g) {a b : Shell p} (ha : a ≠ 0) (hb : b ≠ 0) : a * b ≠ 0 := fun h => match F.mul_eq_zero h with | .inl e => ha e | .inr e => hb e /-- Cancellation: `a * b = a * c` with `a ≠ 0` gives `b = c`. -/ theorem mul_left_cancel (F : Frame p κ g) {a b c : Shell p} (ha : a ≠ 0) (h : a * b = a * c) : b = c := by have : a * (b + -c) = 0 := by rw [left_distrib, ← mul_neg, h, add_neg] match F.mul_eq_zero this with | .inl e => exact absurd e ha | .inr e => calc b = b + 0 := (add_zero b).symm _ = b + (-c + c) := by rw [neg_add] _ = (b + -c) + c := (add_assoc _ _ _).symm _ = c := by rw [e, zero_add] /-- The square roots of one are `±1`. -/ theorem sq_eq_one (F : Frame p κ g) {x : Shell p} (h : x * x = 1) : x = 1 ∨ x = -1 := by have e : (x + -1) * (x + 1) = 0 := by rw [right_distrib, left_distrib, left_distrib, h, mul_one, neg_one_mul, neg_one_mul] rw [add_assoc, ← add_assoc x (-x), add_neg, zero_add, add_neg] match F.mul_eq_zero e with | .inl e1 => exact .inl (by calc x = x + 0 := (add_zero x).symm _ = x + (-1 + 1) := by rw [neg_add] _ = (x + -1) + 1 := (add_assoc _ _ _).symm _ = 1 := by rw [e1, zero_add]) | .inr e2 => exact .inr (eq_neg_of_add_eq_zero e2) /-! ### The Euclidean datum (00:C1) -/ /-- The half-period `π = 2κ`. -/ def halfPeriod (κ : Nat) : Nat := 2 * κ /-- The oriented quarter-turn `i = −g^κ` (00:C7). -/ def quarterTurn (g : Shell p) (κ : Nat) : Shell p := -(g ^ κ) theorem two_kappa_lt (F : Frame p κ g) : 2 * κ < p - 1 := by rw [F.n_eq]; exact FRC.Nat.mul_lt_mul_of_lt_of_pos (Nat.succ_lt_succ (Nat.succ_lt_succ (Nat.zero_lt_succ 1))) F.cap_pos theorem two_kappa_pos (F : Frame p κ g) : 0 < 2 * κ := Nat.mul_pos (Nat.zero_lt_succ 1) F.cap_pos theorem four_kappa (F : Frame p κ g) : 2 * κ + 2 * κ = p - 1 := by rw [F.n_eq] show 2 * κ + 2 * κ = 2 * 2 * κ rw [FRC.Nat.mul_assoc, ← Nat.two_mul (2 * κ)] /-- 2:D1, 13:H2, 00:C1 — the half-period: `g^{2κ} = −1` for the drive of every frame (the half-turn tautology behind `χ(−1) = e^{iπ}`). -/ theorem half_period (F : Frame p κ g) : g ^ (2 * κ) = -1 := by have hsq : g ^ (2 * κ) * g ^ (2 * κ) = 1 := by rw [← pow_add, F.four_kappa, F.pow_n] match F.sq_eq_one hsq with | .inr e => exact e | .inl e => exact absurd e (F.prim.2 (2 * κ) F.two_kappa_lt F.two_kappa_pos) /-- 1:B3, 2:D2, 13:J2 — the quarter-turn `i = −g^κ` squares to `−1` (the pinning relation `i² + 1 ≡ 0`). -/ theorem quarter_turn_sq (F : Frame p κ g) : quarterTurn g κ * quarterTurn g κ = -1 := by unfold quarterTurn rw [neg_mul_neg, ← pow_add, ← Nat.two_mul, F.half_period] /-- 2:D2 — `g^κ` has order four: `(g^κ)^2 = −1` and `(g^κ)^4 = 1`. -/ theorem quarter_turn_order (F : Frame p κ g) : (g ^ κ) ^ 2 = -1 ∧ (g ^ κ) ^ 4 = 1 := by have h2 : (g ^ κ) ^ 2 = -1 := by rw [← pow_mul, Nat.mul_comm, F.half_period] refine ⟨h2, ?_⟩ show (g ^ κ) ^ (2 * 2) = 1 rw [pow_mul, h2, neg_pow_two, one_pow] /-- 2:D5, 6:B3, 13:B2 — the orientation classes: for `g' = g^u`, the quarter-turn `−g'^κ` is `−g^κ` when `u ≡ 1 (mod 4)` and `−(−g^κ)` when `u ≡ 3 (mod 4)`. -/ theorem orientation_class (F : Frame p κ g) (u : Nat) : (u % 4 = 1 → -((g ^ u) ^ κ) = -(g ^ κ)) ∧ (u % 4 = 3 → -((g ^ u) ^ κ) = -(-(g ^ κ))) := by have h4 : (g ^ κ) ^ 4 = 1 := (F.quarter_turn_order).2 have h2 : (g ^ κ) ^ 2 = -1 := (F.quarter_turn_order).1 have key : (g ^ u) ^ κ = (g ^ κ) ^ u := pow_mul_comm g u κ have hu : (g ^ κ) ^ u = (g ^ κ) ^ (u % 4) := by match FRC.Nat.mod_spec 4 (Nat.zero_lt_succ 3) u with | ⟨q, hq⟩ => calc (g ^ κ) ^ u = (g ^ κ) ^ (4 * q + u % 4) := by rw [← hq] _ = ((g ^ κ) ^ 4) ^ q * (g ^ κ) ^ (u % 4) := by rw [pow_add, pow_mul] _ = (g ^ κ) ^ (u % 4) := by rw [h4, one_pow, one_mul] constructor · intro h1; rw [key, hu, h1, pow_one] · intro h3 rw [key, hu, h3] show -((g ^ κ) ^ (2 + 1)) = -(-(g ^ κ)) rw [pow_add, h2, pow_one, neg_one_mul] theorem sq_mod_two (i : Nat) : (i * i) % 2 = i % 2 := by rw [FRC.Nat.mul_mod i i 2 (Nat.zero_lt_succ 1)] have := Nat.mod_lt i (Nat.zero_lt_succ 1) match i % 2, this with | 0, _ => rfl | 1, _ => rfl | k + 2, hk => exact absurd hk (Nat.not_lt_of_le (Nat.le_add_left 2 k)) /-- 2:D6, 6:B2, 00:C14 — the Euler identity on the shell: with `e = g^i` and `π = 2κ`, `(g^i)^{i·2κ} = (−1)^i` for every natural reading `i` of the quarter-turn — `−1` exactly when `i` is odd. -/ theorem euler_identity (F : Frame p κ g) (i : Nat) : (g ^ i) ^ (i * (2 * κ)) = if i % 2 = 0 then 1 else -1 := by have e1 : (g ^ i) ^ (i * (2 * κ)) = (g ^ (2 * κ)) ^ (i * i) := by rw [← pow_mul, ← pow_mul] show g ^ (i * (i * (2 * κ))) = g ^ (2 * κ * (i * i)) rw [← FRC.Nat.mul_assoc, Nat.mul_comm (i * i)] rw [e1, F.half_period, neg_one_pow, sq_mod_two] /-- 00:C1, 13:J2, 13:I4 — the web closes: `2π ≡ −1` on every shell (`4κ = p − 1`): the height-two pinning `2π_A + 1 ≡ 0`, which holds in every fibre of a composite lift. -/ theorem two_pi (F : Frame p κ g) : (ofNat (2 * halfPeriod κ) : Shell p) = -1 := by apply ext rw [val_ofNat, val_neg, val_one, FRC.Nat.mod_eq_of_lt F.one_lt_p] unfold halfPeriod rw [← FRC.Nat.mul_assoc] show (4 * κ) % p = (p - 1) % p rw [F.n_eq] /-! ### Two is invertible on every shell -/ theorem two_lt_p (F : Frame p κ g) : 2 < p := by rw [F.cap] have h : 4 * 1 ≤ 4 * κ := Nat.mul_le_mul_left 4 F.cap_pos exact Nat.lt_of_lt_of_le (by decide : 2 < 4 * 1 + 1) (Nat.succ_le_succ h) theorem two_ne_zero (F : Frame p κ g) : (2 : Shell p) ≠ 0 := fun h => by have := val_injective h rw [val_lit, val_zero, FRC.Nat.mod_eq_of_lt F.two_lt_p] at this exact Nat.noConfusion this theorem two_eq_one_add_one : (2 : Shell p) = 1 + 1 := ext (by rw [val_add, val_one, val_lit, FRC.Nat.mod_add_mod _ _ _ hp, FRC.Nat.add_mod_mod _ _ _ hp]) theorem two_mul' (x : Shell p) : (2 : Shell p) * x = x + x := by rw [two_eq_one_add_one, right_distrib, one_mul] theorem eq_zero_of_eq_neg (F : Frame p κ g) {x : Shell p} (h : x = -x) : x = 0 := by have h2 : (2 : Shell p) * x = 0 := by rw [two_mul'] calc x + x = x + -x := by rw [← h] _ = 0 := add_neg x match F.mul_eq_zero h2 with | .inl e => exact absurd e F.two_ne_zero | .inr e => exact e /-- 1:Z1 (Theorem 3) — `2s = 0 ⇒ s = 0`: the additive cycle has no element of order two; the antipode of the origin is not a residue. -/ theorem no_south_pole (F : Frame p κ g) (s : Shell p) (h : (2 : Shell p) * s = 0) : s = 0 := match F.mul_eq_zero h with | .inl e => absurd e F.two_ne_zero | .inr e => e end Frame end Shell end FRC /-! inlined: FrcCore/Frame.lean -/ /-! # FrcCore.Frame — the frame's arithmetic (the frame theme) The frame itself, `IsPrimitive`, `Generates`, `Frame`, the half-period, the quarter-turn, the orientation classes and the Euler identity, is `FrameCore.lean` (split off by task LM24, every name unchanged); this file imports it, so a module that imports `Frame` sees both. Since the ledger migration (task LM17) it holds the frame's arithmetic from 1-algebra (scale periodicity, the affine frame, the window law and its read-backs, `ofNat_add`, `ofNat_mul`, the quarter-turn and the fourth roots, the meridian involution, the complex chart, Theorem approx, `natCount`), `ofNat_self` and `ofNat_add_self` (from 13-epi), the root pair (from 10-dimensions) and the counting lemmas of 20-rh, all under their old names in `FRC.Shell` and `FRC.Shell.Frame`. The bounded quantifiers' deciders (from 10-dimensions and 20-rh) are in `Series.lean` since task LM22. No axioms. -/ namespace FRC namespace Shell variable {p : Nat} [Pos p] namespace Frame variable {κ : Nat} {g : Shell p} /-! ## The frame's arithmetic (moved from 1-algebra by the ledger migration, task LM17) -/ /-- 1:D4 (Lemma 2 of 1-algebra, scale periodicity) — the residue grid repeats with the period `p − 1` of the drive: `g^{n + (p−1)} = g^n`, hence `x·g^{n + (p−1)} = x·g^n` for every `x`. -/ theorem scale_periodic (F : Frame p κ g) (x : Shell p) (n : Nat) : x * g ^ (n + (p - 1)) = x * g ^ n := by rw [pow_add, F.pow_n, mul_one] /-- The affine frame `(a, b)` of 1-algebra (Definition 2): the transported product `x ⊗ z := a + b·((x − a)/b)·((z − a)/b)`, written with `y` the inverse of `b`. -/ def affineMul (a b y x z : Shell p) : Shell p := a + b * ((x + -a) * y) * ((z + -a) * y) /-- 1:B4 (Definition 2 of 1-algebra) — in the affine frame `(a, b)` the multiplicative unit is `a + b`, not `b`: `(a + b) ⊗ z = z` for every `z`. -/ theorem affine_frame_unit {a b y : Shell p} (hby : b * y = 1) (z : Shell p) : affineMul a b y (a + b) z = z := by unfold affineMul have e1 : a + b + -a = b := by rw [add_comm a b, add_assoc, add_neg, add_zero] rw [e1, hby, mul_one, mul_left_comm b, hby, mul_one, add_comm z (-a), ← add_assoc, add_neg, zero_add] /-- 1:D2 (the window law, injectivity) — two window integers `x, y ≤ H` with `2H < p` that read as the same residue are equal: `ofNat x = ofNat y → x = y`. (Both are below `p`, so the residues are the integers.) -/ theorem window_injective {H x y : Nat} (hH : 2 * H < p) (hx : x ≤ H) (hy : y ≤ H) (h : (ofNat x : Shell p) = ofNat y) : x = y := by have hxp : x < p := Nat.lt_of_le_of_lt hx (Nat.lt_of_le_of_lt (Nat.le_add_left H H) (Nat.two_mul H ▸ hH)) have hyp : y < p := Nat.lt_of_le_of_lt hy (Nat.lt_of_le_of_lt (Nat.le_add_left H H) (Nat.two_mul H ▸ hH)) have := val_injective h rw [val_ofNat, val_ofNat, FRC.Nat.mod_eq_of_lt hxp, FRC.Nat.mod_eq_of_lt hyp] at this exact this theorem ofNat_add (x y : Nat) : (ofNat x : Shell p) + ofNat y = ofNat (x + y) := ext (by rw [val_add, val_ofNat, val_ofNat, val_ofNat, FRC.Nat.mod_add_mod _ _ _ hp, FRC.Nat.add_mod_mod _ _ _ hp]) theorem ofNat_mul (x y : Nat) : (ofNat x : Shell p) * ofNat y = ofNat (x * y) := ext (by rw [val_mul, val_ofNat, val_ofNat, val_ofNat, FRC.Nat.mod_mul_mod _ _ _ hp, FRC.Nat.mul_mod_mod _ _ _ hp]) /-- `p ≡ 0` on the shell. -/ theorem ofNat_self : (ofNat p : Shell p) = 0 := by apply ext; show p % p = 0; exact FRC.Nat.mod_self p Pos.pos theorem ofNat_add_self (n : Nat) : (ofNat (n + p) : Shell p) = ofNat n := by rw [← ofNat_add, ofNat_self, add_zero] /-- 1:D2, the read-back of sums: for `x, y ≤ H` and `4H < p`, the residue of `x + y` determines the integer `x + y` among the integers `z ≤ 2H`. -/ theorem window_add_readback {H x y z : Nat} (hH : 2 * (2 * H) < p) (hx : x ≤ H) (hy : y ≤ H) (hz : z ≤ 2 * H) (h : (ofNat x : Shell p) + ofNat y = ofNat z) : x + y = z := by rw [ofNat_add] at h exact window_injective hH (by rw [Nat.two_mul]; exact Nat.add_le_add hx hy) hz h /-- 1:D2, the read-back of products: for `x, y ≤ H` and `2H² < p`, the residue of `x·y` determines the integer `x·y` among the integers `z ≤ H²`. -/ theorem window_mul_readback {H x y z : Nat} (hH : 2 * (H * H) < p) (hx : x ≤ H) (hy : y ≤ H) (hz : z ≤ H * H) (h : (ofNat x : Shell p) * ofNat y = ofNat z) : x * y = z := by rw [ofNat_mul] at h exact window_injective hH (Nat.mul_le_mul hx hy) hz h /-- 1:D2, the signed window: `x` and `−y` (`x, y ≤ H`, `2H < p`) read as the same residue only when both are zero — the window's positive and negative halves do not overlap. -/ theorem window_signed {H x y : Nat} (hH : 2 * H < p) (hx : x ≤ H) (hy : y ≤ H) (h : (ofNat x : Shell p) = -(ofNat y)) : x = 0 ∧ y = 0 := by have hxp : x < p := Nat.lt_of_le_of_lt hx (Nat.lt_of_le_of_lt (Nat.le_add_left H H) (Nat.two_mul H ▸ hH)) have hyp : y < p := Nat.lt_of_le_of_lt hy (Nat.lt_of_le_of_lt (Nat.le_add_left H H) (Nat.two_mul H ▸ hH)) have hv := val_injective h rw [val_ofNat, val_neg, val_ofNat, FRC.Nat.mod_eq_of_lt hxp, FRC.Nat.mod_eq_of_lt hyp] at hv -- hv : x = (p - y) % p match Nat.decEq y 0 with | .isTrue hy0 => rw [hy0, Nat.sub_zero, FRC.Nat.mod_self p hp] at hv exact ⟨hv, hy0⟩ | .isFalse hy0 => have hpy : p - y < p := Nat.sub_lt hp (Nat.pos_of_ne_zero hy0) rw [FRC.Nat.mod_eq_of_lt hpy] at hv -- x = p − y with x ≤ H, y ≤ H gives p = x + y ≤ 2H < p have : p = x + y := by rw [hv, FRC.Nat.sub_add_cancel (Nat.le_of_lt hyp)] have hle : x + y ≤ 2 * H := by rw [Nat.two_mul]; exact Nat.add_le_add hx hy exact absurd (Nat.lt_of_le_of_lt (this ▸ hle) hH) (Nat.lt_irrefl p) /-- 1:B2 (Theorem 1, existence clause) — a quarter-turn `u` with `u² = −1` exists on every shell. -/ theorem quarter_turn_exists (F : Frame p κ g) : ∃ u : Shell p, u * u = -1 := ⟨quarterTurn g κ, F.quarter_turn_sq⟩ /-- 1:B2 (Theorem 1, the structural set) — the fourth roots of unity are exactly `1, −1, i, −i`. -/ theorem fourth_roots (F : Frame p κ g) (x : Shell p) : x ^ 4 = 1 ↔ x = 1 ∨ x = -1 ∨ x = quarterTurn g κ ∨ x = -(quarterTurn g κ) := by have h4 : x ^ 4 = (x * x) * (x * x) := by rw [show (4 : Nat) = 2 * 2 from rfl, pow_mul, pow_two, pow_two] have hi := F.quarter_turn_sq constructor · intro h rw [h4] at h match F.sq_eq_one h with | .inl e => match F.sq_eq_one e with | .inl e1 => exact .inl e1 | .inr e1 => exact .inr (.inl e1) | .inr e => -- x² = −1 = i²: (x + −i)(x + i) = 0 have e2 : (x + -(quarterTurn g κ)) * (x + quarterTurn g κ) = 0 := by rw [right_distrib, left_distrib, left_distrib, e, ← neg_mul, ← neg_mul, hi, neg_neg, mul_comm (quarterTurn g κ) x] rw [add_assoc, ← add_assoc (x * quarterTurn g κ), add_neg, zero_add, neg_add] match F.mul_eq_zero e2 with | .inl e3 => exact .inr (.inr (.inl (by calc x = x + 0 := (add_zero x).symm _ = x + (-(quarterTurn g κ) + quarterTurn g κ) := by rw [neg_add] _ = (x + -(quarterTurn g κ)) + quarterTurn g κ := (add_assoc _ _ _).symm _ = quarterTurn g κ := by rw [e3, zero_add]))) | .inr e3 => exact .inr (.inr (.inr (eq_neg_of_add_eq_zero e3))) · intro h match h with | .inl e => rw [e, one_pow] | .inr (.inl e) => rw [h4, e, neg_mul_neg, one_mul, one_mul] | .inr (.inr (.inl e)) => rw [h4, e, hi, neg_mul_neg, one_mul] | .inr (.inr (.inr e)) => rw [h4, e, neg_mul_neg, hi, neg_mul_neg, one_mul] /-- 1:C4 (Definition 5 (a)) — the meridian involution: `(−a)·g^{n + 2κ} = a·g^n`. -/ theorem meridian_involution (F : Frame p κ g) (a : Shell p) (n : Nat) : -a * g ^ (n + 2 * κ) = a * g ^ n := by rw [pow_add, F.half_period, mul_comm (g ^ n), ← mul_assoc, neg_mul_neg, mul_one] /-- The complex chart: pairs `(a, b)` read as `a + b·X` with `X² = −1`, multiplied as `(a, b)(c, d) = (ac − bd, ad + bc)`. -/ def cmul (x y : Shell p × Shell p) : Shell p × Shell p := (x.1 * y.1 + -(x.2 * y.2), x.1 * y.2 + x.2 * y.1) /-- 1:E2 (Proposition 5 reversed) — on a shell that already has a square root of `−1` the complex chart is not a field: `(i, 1)·(−i, 1) = (0, 0)` with both factors nonzero (`X + i` and `X − i` are zero divisors). -/ theorem complex_chart_zero_divisor (F : Frame p κ g) : cmul (quarterTurn g κ, (1 : Shell p)) (-(quarterTurn g κ), 1) = (0, 0) ∧ (quarterTurn g κ, (1 : Shell p)) ≠ (0, 0) ∧ (-(quarterTurn g κ), (1 : Shell p)) ≠ (0, 0) := by refine ⟨?_, fun h => F.one_ne_zero (congrArg Prod.snd h), fun h => F.one_ne_zero (congrArg Prod.snd h)⟩ unfold cmul show (quarterTurn g κ * -(quarterTurn g κ) + -(1 * 1), quarterTurn g κ * 1 + 1 * -(quarterTurn g κ)) = (0, 0) rw [← mul_neg, F.quarter_turn_sq, neg_neg, one_mul, add_neg, mul_one, one_mul, add_neg] /-- 1:D6 (Theorem approx, the range at `p = 13`, `g = 2`): every grid point `x / 2^n` with `x < 13` and `n ≥ 3` is at most `3/2` — as the integer statement `2x ≤ 3·2^n`. -/ theorem approx_obstruction (n x : Nat) (hn : 3 ≤ n) (hx : x < 13) : 2 * x ≤ 3 * 2 ^ n := by have h8 : 2 ^ 3 ≤ 2 ^ n := Nat.pow_le_pow_right (Nat.zero_lt_succ 1) hn have h1 : 2 * x ≤ 2 * 12 := Nat.mul_le_mul_left 2 (Nat.le_of_lt_succ hx) have h2 : 3 * 2 ^ 3 ≤ 3 * 2 ^ n := Nat.mul_le_mul_left 3 h8 exact Nat.le_trans h1 h2 /-- The number of `x < n` with `P x`, as a sum of `0`s and `1`s. -/ def natCount (P : Nat → Prop) [DecidablePred P] : Nat → Nat | 0 => 0 | n + 1 => natCount P n + if P n then 1 else 0 theorem natCount_ne_zero (n : Nat) : natCount (fun x => x ≠ 0) (n + 1) = n := by induction n with | zero => rfl | succ n ih => show natCount (fun x => x ≠ 0) (n + 1) + (if n + 1 ≠ 0 then 1 else 0) = n + 1 rw [ih, ite_eq_left (Nat.succ_ne_zero n)] /-- 10:E4, 10:P2 — the root pair: if `x² = a` with `x ≠ 0` then `y² = a` iff `y = x` or `y = −x`, and `−x ≠ x`; each quadratic defining congruence has exactly two roots on a framed Carrier. -/ theorem root_pair (F : Frame p κ g) (a x : Shell p) (hx : x * x = a) (hx0 : x ≠ 0) : (∀ y : Shell p, y * y = a ↔ (y = x ∨ y = -x)) ∧ -x ≠ x := by refine ⟨fun y => ⟨fun hy => ?_, fun hy => ?_⟩, fun h => hx0 (F.eq_zero_of_eq_neg h.symm)⟩ · have h0 : (y + -x) * (y + x) = 0 := by rw [Shell.right_distrib, Shell.left_distrib, Shell.left_distrib, ← Shell.neg_mul, ← Shell.neg_mul, Shell.mul_comm y x, Shell.add_assoc, ← Shell.add_assoc (x * y), Shell.add_neg, Shell.zero_add, hy, hx, Shell.add_neg] rcases F.mul_eq_zero h0 with h | h · left; exact (Shell.eq_neg_of_add_eq_zero h).trans (Shell.neg_neg x) · right; exact Shell.eq_neg_of_add_eq_zero h · rcases hy with rfl | rfl · exact hx · rw [Shell.neg_mul_neg]; exact hx /-- Counting where nothing satisfies the predicate. -/ theorem natCount_eq_zero (P : Nat → Prop) [DecidablePred P] : ∀ n, (∀ x, x < n → ¬ P x) → natCount P n = 0 | 0, _ => rfl | n + 1, h => by show natCount P n + (if P n then 1 else 0) = 0 rw [natCount_eq_zero P n (fun x hx => h x (Nat.lt_succ_of_lt hx)), ite_eq_right (h n (Nat.lt_succ_self n))] /-- Counting through an equivalent predicate. -/ theorem natCount_congr (P Q : Nat → Prop) [DecidablePred P] [DecidablePred Q] : ∀ n, (∀ x, x < n → (P x ↔ Q x)) → natCount P n = natCount Q n | 0, _ => rfl | n + 1, h => by show natCount P n + (if P n then 1 else 0) = natCount Q n + (if Q n then 1 else 0) rw [natCount_congr P Q n (fun x hx => h x (Nat.lt_succ_of_lt hx))] have e := h n (Nat.lt_succ_self n) match (inferInstance : Decidable (Q n)) with | isTrue hq => rw [ite_eq_left hq, ite_eq_left (e.2 hq)] | isFalse hq => rw [ite_eq_right hq, ite_eq_right (fun hp => hq (e.1 hp))] end Frame end Shell end FRC /-! inlined: FrcCore/Parity.lean -/ /-! # FrcCore.Parity — the square class of the drive is the parity of its exponent (the frame theme) On every frame `g^m` is a square exactly when the drive-step count `m` is even (8:B5, `parity_iff`); the drive and its inverse are nonsquares (8:B3, 8:B6). Split from `Orbit.lean` by the ledger migration (task LM24), every name unchanged, so that a theme needing the square class does not carry the orbit of the generators; `Orbit.lean` imports this file. No axioms. -/ namespace FRC namespace Shell namespace Frame variable {p : Nat} [Pos p] {κ : Nat} {g : Shell p} /-! ## The square class of the drive is the parity of its exponent (moved from 8-dirac, task LM17) -/ theorem two_mul_mod (l : Nat) : (2 * l) % 2 = 0 := by rw [← Nat.add_zero (2 * l)]; exact FRC.Nat.add_mul_mod_self_left 0 l 2 (Nat.zero_lt_succ 1) theorem mod_two_of_mod_four_mul (m q : Nat) : (4 * q + m) % 2 = m % 2 := by have : 4 * q + m = 2 * (2 * q) + m := by rw [← FRC.Nat.mul_assoc] rw [this, FRC.Nat.add_mul_mod_self_left m (2 * q) 2 (Nat.zero_lt_succ 1)] theorem mod_n_mod_two (F : Frame p κ g) (m : Nat) : (m % (p - 1)) % 2 = m % 2 := by match FRC.Nat.mod_spec (p - 1) F.n_pos m with | ⟨q, hq⟩ => have e : m = 4 * (κ * q) + m % (p - 1) := by rw [← FRC.Nat.mul_assoc, ← F.n_eq]; exact hq calc (m % (p - 1)) % 2 = (4 * (κ * q) + m % (p - 1)) % 2 := (mod_two_of_mod_four_mul _ _).symm _ = m % 2 := by rw [← e] /-- 8:B5 — the square class is chronon parity: on every frame, `g^m` is a square exactly when the drive-step count `m` is even (Theorem `parity`). -/ theorem parity_iff (F : Frame p κ g) (m : Nat) : (∃ y : Shell p, y * y = g ^ m) ↔ m % 2 = 0 := by constructor · rintro ⟨y, hy⟩ have hy0 : y ≠ 0 := fun h0 => F.pow_ne_zero m (by rw [← hy, h0, Shell.mul_zero]) obtain ⟨l, hl, hgl⟩ := F.eq_pow_of_ne_zero hy0 have h2 : g ^ (2 * l) = g ^ m := by rw [Nat.mul_comm, Shell.pow_mul, Shell.pow_two, hgl]; exact hy rw [F.pow_mod, F.pow_mod m] at h2 have h3 := F.pow_inj (Nat.mod_lt _ F.n_pos) (Nat.mod_lt _ F.n_pos) h2 rw [← mod_n_mod_two F m, ← h3, mod_n_mod_two F] exact two_mul_mod l · intro h match FRC.Nat.mod_spec 2 (Nat.zero_lt_succ 1) m with | ⟨q, hq⟩ => rw [h, Nat.add_zero] at hq exact ⟨g ^ q, by rw [hq, Nat.mul_comm, Shell.pow_mul, Shell.pow_two]⟩ /-- 8:B3 — the drive is a nonsquare on every frame (`m = 1`). -/ theorem drive_nonsquare (F : Frame p κ g) : ¬ ∃ y : Shell p, y * y = g := fun ⟨y, hy⟩ => Nat.noConfusion ((parity_iff F 1).1 ⟨y, by rw [Shell.pow_one]; exact hy⟩) theorem mod_two_cases (m : Nat) : m % 2 = 0 ∨ m % 2 = 1 := by have := Nat.mod_lt m (Nat.zero_lt_succ 1) match m % 2, this with | 0, _ => exact .inl rfl | 1, _ => exact .inr rfl | k + 2, hk => exact absurd hk (Nat.not_lt_of_le (Nat.le_add_left 2 k)) theorem succ_mod_two_eq_zero_iff (m : Nat) : (m + 1) % 2 = 0 ↔ m % 2 = 1 := by rw [FRC.Nat.add_mod m 1 2 (Nat.zero_lt_succ 1)] rcases mod_two_cases m with h | h <;> rw [h] · exact ⟨fun e => Nat.noConfusion e, fun e => Nat.noConfusion e⟩ · exact ⟨fun _ => rfl, fun _ => rfl⟩ /-- The inverse of the drive is `g^{p−2}`: every `y` with `g y = 1` is an odd power of `g`. -/ theorem inv_drive_odd (F : Frame p κ g) {y : Shell p} (hy : g * y = 1) : ∃ l, l < p - 1 ∧ g ^ l = y ∧ l % 2 = 1 := by have hy0 : y ≠ 0 := fun h0 => F.one_ne_zero (by rw [← hy, h0, Shell.mul_zero]) obtain ⟨l, hl, hgl⟩ := F.eq_pow_of_ne_zero hy0 refine ⟨l, hl, hgl, ?_⟩ have h1 : g ^ (l + 1) = 1 := by rw [Shell.pow_succ, hgl, Shell.mul_comm]; exact hy have h2 := F.mod_eq_zero_of_pow_eq_one h1 have h3 : l + 1 = p - 1 := by match Nat.lt_or_ge (l + 1) (p - 1) with | .inl hlt => exact absurd (by rw [FRC.Nat.mod_eq_of_lt hlt] at h2; exact h2) (Nat.succ_ne_zero l) | .inr hge => exact Nat.le_antisymm (Nat.succ_le_of_lt hl) hge have h4 : (l + 1) % 2 = 0 := by rw [h3, F.n_eq, ← Nat.add_zero (4 * κ), mod_two_of_mod_four_mul] exact (succ_mod_two_eq_zero_iff l).1 h4 /-- 8:B3, 8:B6 — the reframing flip preserves the class: the inverse of the drive is a nonsquare (an odd power of `g`), so `[g⁻¹] = [g]`. -/ theorem inv_drive_nonsquare (F : Frame p κ g) {y : Shell p} (hy : g * y = 1) : ¬ ∃ r : Shell p, r * r = y := fun h => by obtain ⟨l, _, hgl, hodd⟩ := inv_drive_odd F hy rw [← hgl] at h have h2 := (parity_iff F l).1 h rw [hodd] at h2 exact Nat.noConfusion h2 end Frame end Shell end FRC /-! inlined: FrcCore/Transform.lean -/ /-! # FrcCore.Transform — the shell Fourier transform on the cycle: `W`, the reversal `J`, `F = i W` (the frame theme) The geometric sum gives the principal-root identity (2:F1, Prop. 6.1 of 2-geometry) and the entrywise inversion of the shell Fourier matrix `W k j = g^{jk}`: `Σ_l W k l · (−g^{−lj}) = [k = j]` (2:F3, Prop. 6.3; 6:B5 in matrix form); the reversal `rev`, `J`, and the quarter-turn transform `F = i W` with `W² = −J`, `F² = J`, `J² = I` and `W J = J W` (6:B5, 6:B7). Split from `Sum.lean` by the ledger migration (task LM25), every name unchanged, so that the fourier theme takes the transform without the orbits (gate G10). Since task LM36 it also holds the sum over the nonzero residues reindexed by the drive (`sum_units_eq_sum_pow`, from `Sum.lean`) and the frame `frame13` (from `Instances.lean`), names unchanged, so that the horizon theme takes them without the orbits. No axioms. -/ namespace FRC namespace Shell variable {p : Nat} [Pos p] namespace Frame variable {κ : Nat} {g : Shell p} /-- `Σ_{l x ^ l) n = 0 := by have h := geom_sum_mul x n rw [hn, add_neg] at h match F.mul_eq_zero h with | .inl e => exact e | .inr e => exact absurd (by calc x = x + 0 := (add_zero x).symm _ = x + (-1 + 1) := by rw [neg_add] _ = (x + -1) + 1 := (add_assoc _ _ _).symm _ = 1 := by rw [e, zero_add]) hx /-- 6:B6 — the normalization constant read in the field: `n = p − 1 ≡ −1`. -/ theorem ofNat_n (F : Frame p κ g) : (ofNat (p - 1) : Shell p) = -1 := by apply ext rw [val_ofNat, val_neg, val_one, FRC.Nat.mod_eq_of_lt F.one_lt_p, FRC.Nat.mod_eq_of_lt (Nat.sub_lt Pos.pos (Nat.zero_lt_succ 0))] /-- 2:F1 (Prop. 6.1) — `g` is a principal root of unity: `g^n = 1`, `Σ_{j (g ^ k) ^ j) (p - 1) = 0 ∧ (ofNat (p - 1) : Shell p) = -1 := by refine ⟨F.pow_n, ?_, F.ofNat_n⟩ apply F.geom_sum_eq_zero · rw [pow_mul_comm, F.pow_n, one_pow] · exact F.prim.2 k hk hk0 /-- `g^{k + (n − j)} = 1` exactly when `k = j`, for `k, j < n`. -/ theorem pow_shift_eq_one_iff (F : Frame p κ g) {k j : Nat} (hk : k < p - 1) (hj : j < p - 1) : g ^ (k + (p - 1 - j)) = 1 ↔ k = j := by have hn := F.n_pos have hjn : p - 1 - j + j = p - 1 := FRC.Nat.sub_add_cancel (Nat.le_of_lt hj) constructor · intro h have hm := F.mod_eq_zero_of_pow_eq_one h match Nat.lt_or_ge k j with | .inl hlt => have hlt' : k + (p - 1 - j) < p - 1 := by have := Nat.add_lt_add_right hlt (p - 1 - j) rw [Nat.add_comm j, hjn] at this exact this rw [FRC.Nat.mod_eq_of_lt hlt'] at hm have hpos : 0 < p - 1 - j := by refine Nat.lt_of_add_lt_add_right (n := j) ?_ rw [Nat.zero_add, hjn]; exact hj exact absurd hm (Nat.ne_of_gt (Nat.lt_of_lt_of_le hpos (Nat.le_add_left _ _))) | .inr hge => have e : k + (p - 1 - j) = (p - 1) * 1 + (k - j) := by rw [Nat.mul_one] calc k + (p - 1 - j) = (j + (k - j)) + (p - 1 - j) := by rw [FRC.Nat.add_sub_of_le hge] _ = (p - 1 - j + j) + (k - j) := by rw [Nat.add_comm j (k - j), Nat.add_assoc, Nat.add_comm (k - j), Nat.add_comm j (p - 1 - j)] _ = p - 1 + (k - j) := by rw [hjn] rw [e, FRC.Nat.add_mul_mod_self_left _ _ _ hn, FRC.Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (Nat.sub_le k j) hk)] at hm have := FRC.Nat.add_sub_of_le hge rw [hm, Nat.add_zero] at this exact this.symm · intro e rw [e, FRC.Nat.add_sub_of_le (Nat.le_of_lt hj), F.pow_n] /-- 2:F3 (Prop. 6.3), 6:B5 — the inversion of the shell Fourier matrix, entrywise: with `W k j = g^{jk}` and `W' l j = −g^{(n−j)l}` (`= −g^{−lj}`), `Σ_{l g ^ (l * k) * -(g ^ ((p - 1 - j) * l))) (p - 1) = if k = j then 1 else 0 := by have hsum : sumRange (fun l => g ^ (l * k) * -(g ^ ((p - 1 - j) * l))) (p - 1) = -(sumRange (fun l => (g ^ (k + (p - 1 - j))) ^ l) (p - 1)) := by rw [← sum_neg] apply sum_congr intro l _ rw [← mul_neg, ← pow_add, ← pow_mul, Nat.mul_comm l k, ← FRC.Nat.add_mul] rw [hsum] exact match Nat.decEq k j with | .isTrue e => by rw [ite_eq_left e] have h1 : g ^ (k + (p - 1 - j)) = 1 := (F.pow_shift_eq_one_iff hk hj).2 e have : sumRange (fun l => (g ^ (k + (p - 1 - j))) ^ l) (p - 1) = ofNat (p - 1) * 1 := by rw [← sum_const]; apply sum_congr; intro l _; rw [h1, one_pow] rw [this, F.ofNat_n, mul_one, neg_neg] | .isFalse e => by rw [ite_eq_right e] have h1 : g ^ (k + (p - 1 - j)) ≠ 1 := fun h => e ((F.pow_shift_eq_one_iff hk hj).1 h) rw [F.geom_sum_eq_zero _ (by rw [pow_mul_comm, F.pow_n, one_pow]) h1, neg_zero] /-- `g^{k + j} = 1` exactly when `(k + j) % n = 0`, i.e. `j` is the reversal `−k` of `k` (`k, j < n`). -/ theorem pow_add_eq_one_iff (F : Frame p κ g) (k j : Nat) : g ^ (k + j) = 1 ↔ (k + j) % (p - 1) = 0 := ⟨F.mod_eq_zero_of_pow_eq_one, F.pow_eq_one_of_mod⟩ /-- 6:B5 (the shell Fourier matrix squares to the reversal, entrywise): with `W k j = g^{jk}` and `J k j = [(k + j) % n = 0]`, `Σ_{l g ^ (l * k) * g ^ (j * l)) (p - 1) = -(if (k + j) % (p - 1) = 0 then 1 else 0) := by have hsum : sumRange (fun l => g ^ (l * k) * g ^ (j * l)) (p - 1) = sumRange (fun l => (g ^ (k + j)) ^ l) (p - 1) := by apply sum_congr; intro l _ rw [← pow_add, ← pow_mul, Nat.mul_comm l k, ← FRC.Nat.add_mul] rw [hsum] exact match Nat.decEq ((k + j) % (p - 1)) 0 with | .isTrue e => by rw [ite_eq_left e] have h1 : g ^ (k + j) = 1 := F.pow_eq_one_of_mod e have : sumRange (fun l => (g ^ (k + j)) ^ l) (p - 1) = ofNat (p - 1) * 1 := by rw [← sum_const]; apply sum_congr; intro l _; rw [h1, one_pow] rw [this, F.ofNat_n, mul_one] | .isFalse e => by rw [ite_eq_right e, neg_zero] exact F.geom_sum_eq_zero _ (by rw [pow_mul_comm, F.pow_n, one_pow]) (fun h => e (F.mod_eq_zero_of_pow_eq_one h)) /-! ### The reversal, the Fourier matrix `W`, the quarter-turn transform `F = i·W` (6:B5, B7) -/ /-- The reversal `rev n k = (n − k) % n`: the index `l` with `(k + l) % n = 0`. -/ def rev (n k : Nat) : Nat := (n - k) % n theorem rev_lt {n : Nat} (hn : 0 < n) (k : Nat) : rev n k < n := Nat.mod_lt _ hn theorem rev_zero (n : Nat) (hn : 0 < n) : rev n 0 = 0 := by unfold rev; rw [Nat.sub_zero]; exact FRC.Nat.mod_self n hn theorem rev_of_pos {n k : Nat} (hk : k < n) (hk0 : 0 < k) : rev n k = n - k := by unfold rev; exact FRC.Nat.mod_eq_of_lt (Nat.sub_lt (Nat.lt_of_lt_of_le hk0 (Nat.le_of_lt hk)) hk0) theorem rev_add_mod {n k : Nat} (hk : k < n) : (rev n k + k) % n = 0 := by have hn : 0 < n := Nat.lt_of_le_of_lt (Nat.zero_le k) hk exact match Nat.decEq k 0 with | isTrue e => by rw [e, rev_zero n hn]; rfl | isFalse e => by rw [rev_of_pos hk (Nat.pos_of_ne_zero e), FRC.Nat.sub_add_cancel (Nat.le_of_lt hk)] exact FRC.Nat.mod_self n hn theorem rev_rev {n k : Nat} (hk : k < n) : rev n (rev n k) = k := by have hn : 0 < n := Nat.lt_of_le_of_lt (Nat.zero_le k) hk exact match Nat.decEq k 0 with | isTrue e => by rw [e, rev_zero n hn, rev_zero n hn] | isFalse e => by have hk0 := Nat.pos_of_ne_zero e rw [rev_of_pos hk hk0] have hnk : n - k < n := Nat.sub_lt (Nat.lt_of_lt_of_le hk0 (Nat.le_of_lt hk)) hk0 have hnk0 : 0 < n - k := by refine Nat.lt_of_add_lt_add_right (n := k) ?_ rw [Nat.zero_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hk)]; exact hk rw [rev_of_pos hnk hnk0] calc n - (n - k) = (n - k + k) - (n - k) := by rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hk)] _ = k := FRC.Nat.add_sub_cancel_left _ _ /-- `(k + l) % n = 0` exactly when `l` is the reversal of `k` (`k, l < n`). -/ theorem add_mod_eq_zero_iff {n k l : Nat} (hk : k < n) (hl : l < n) : (k + l) % n = 0 ↔ l = rev n k := by have hn : 0 < n := Nat.lt_of_le_of_lt (Nat.zero_le k) hk constructor · intro h exact match Nat.decEq k 0 with | isTrue e => by rw [e, Nat.zero_add, FRC.Nat.mod_eq_of_lt hl] at h rw [e, rev_zero n hn, h] | isFalse e => by have hk0 := Nat.pos_of_ne_zero e rw [rev_of_pos hk hk0] exact match Nat.lt_or_ge l (n - k) with | Or.inl hlt => by have : k + l < n := by have := Nat.add_lt_add_left hlt k rw [FRC.Nat.add_sub_of_le (Nat.le_of_lt hk)] at this; exact this rw [FRC.Nat.mod_eq_of_lt this] at h exact absurd h (Nat.ne_of_gt (Nat.lt_of_lt_of_le hk0 (Nat.le_add_right k l))) | Or.inr hge => by have e1 : k + l = n * 1 + (l - (n - k)) := by rw [Nat.mul_one] calc k + l = k + ((n - k) + (l - (n - k))) := by rw [FRC.Nat.add_sub_of_le hge] _ = (k + (n - k)) + (l - (n - k)) := (Nat.add_assoc _ _ _).symm _ = n + (l - (n - k)) := by rw [FRC.Nat.add_sub_of_le (Nat.le_of_lt hk)] rw [e1, FRC.Nat.add_mul_mod_self_left _ _ _ hn, FRC.Nat.mod_eq_of_lt (Nat.lt_of_le_of_lt (Nat.sub_le _ _) hl)] at h have := FRC.Nat.add_sub_of_le hge rw [h, Nat.add_zero] at this exact this.symm · intro e; rw [e, Nat.add_comm]; exact rev_add_mod hk /-- The shell Fourier matrix, `W k j = g^{jk}` (6:B5's convention). -/ def W (g : Shell p) (k j : Nat) : Shell p := g ^ (j * k) /-- The reversal matrix `J k j = [(k + j) % n = 0]`. -/ def J (n k j : Nat) : Shell p := if (k + j) % n = 0 then 1 else 0 /-- The quarter-turn transform `F = i·W`, `i = −g^κ`. -/ def Fmat (g : Shell p) (κ k j : Nat) : Shell p := quarterTurn g κ * W g k j theorem J_eq {n k l : Nat} (hk : k < n) (hl : l < n) : (J n k l : Shell p) = (if l = rev n k then (1 : Shell p) else 0) := by unfold J exact match Nat.decEq l (rev n k) with | isTrue e => by rw [ite_eq_left e, ite_eq_left ((add_mod_eq_zero_iff hk hl).2 e)] | isFalse e => by rw [ite_eq_right e, ite_eq_right (fun h => e ((add_mod_eq_zero_iff hk hl).1 h))] /-- 6:B5 (`W² = −J`, entrywise), in the matrix notation. -/ theorem W_sq' (F : Frame p κ g) (k j : Nat) : sumRange (fun l => W g k l * W g l j) (p - 1) = -(J (p - 1) k j) := F.W_sq k j /-- 6:B5, 6:B7 (`J² = 1`, entrywise): the reversal is an involution, so `F⁴ = J² = 1`. -/ theorem J_sq (F : Frame p κ g) {k j : Nat} (hk : k < p - 1) (hj : j < p - 1) : sumRange (fun l => (J (p - 1) k l : Shell p) * J (p - 1) l j) (p - 1) = (if k = j then (1 : Shell p) else 0) := by have hn := F.n_pos have hr : rev (p - 1) k < p - 1 := rev_lt hn k rw [sum_eq_single hr (fun l hl hne => by rw [J_eq hk hl, ite_eq_right hne, zero_mul])] rw [J_eq hk hr, ite_eq_left rfl, one_mul, J_eq hr hj, rev_rev hk] exact match Nat.decEq k j with | isTrue e => by rw [ite_eq_left e, ite_eq_left e.symm] | isFalse e => by rw [ite_eq_right e, ite_eq_right (fun h => e h.symm)] /-- 6:B5, 6:B7 (`F² = J`, entrywise): the quarter-turn transform squares to the reversal. -/ theorem F_sq (F : Frame p κ g) (k j : Nat) : sumRange (fun l => Fmat g κ k l * Fmat g κ l j) (p - 1) = J (p - 1) k j := by have e : ∀ l, Fmat g κ k l * Fmat g κ l j = (quarterTurn g κ * quarterTurn g κ) * (W g k l * W g l j) := by intro l; unfold Fmat rw [mul_assoc, mul_left_comm (W g k l), ← mul_assoc] rw [sum_congr _ (fun l _ => e l), sum_mul_left, F.W_sq' k j, F.quarter_turn_sq, ← neg_mul, one_mul, neg_neg] /-- 6:B7 (`W J = J W`, entrywise). -/ theorem W_J_comm (F : Frame p κ g) {k j : Nat} (hk : k < p - 1) (hj : j < p - 1) : sumRange (fun l => W g k l * J (p - 1) l j) (p - 1) = sumRange (fun l => J (p - 1) k l * W g l j) (p - 1) := by have hn := F.n_pos have hrj : rev (p - 1) j < p - 1 := rev_lt hn j have hrk : rev (p - 1) k < p - 1 := rev_lt hn k rw [sum_eq_single hrj (fun l hl hne => by rw [J_eq hl hj, ite_eq_right (fun e => hne (by rw [e, rev_rev hl])), mul_zero])] rw [sum_eq_single hrk (fun l hl hne => by rw [J_eq hk hl, ite_eq_right hne, zero_mul])] rw [J_eq hrj hj, ite_eq_left (rev_rev hj).symm, mul_one, J_eq hk hrk, ite_eq_left rfl, one_mul] unfold W -- both are the inverse of g^{jk} apply inv_unique (y := g ^ (j * k)) · rw [← pow_add, ← FRC.Nat.add_mul, F.pow_mod, ← FRC.Nat.mod_mul_mod _ _ _ hn, rev_add_mod hj, Nat.zero_mul, FRC.Nat.zero_mod, pow_zero] · rw [← pow_add, ← Nat.left_distrib, F.pow_mod, ← FRC.Nat.mul_mod_mod _ _ _ hn, rev_add_mod hk, Nat.mul_zero, FRC.Nat.zero_mod, pow_zero] /-- The sum over the nonzero residues equals the sum over the powers of the drive: `x = g^m` reindexes. -/ theorem sum_units_eq_sum_pow (F : Frame p κ g) (f : Shell p → Shell p) : sumRange (fun l => f (ofNat (l + 1))) (p - 1) = sumRange (fun m => f (g ^ m)) (p - 1) := by have hn : p = (p - 1) + 1 := (FRC.Nat.sub_add_cancel Pos.pos).symm have hpos : ∀ m, 1 ≤ (g ^ m).val := fun m => Nat.pos_of_ne_zero (fun h0 => F.pow_ne_zero m (ext (by rw [h0, val_zero]))) have hlt : ∀ m, m < p - 1 → (g ^ m).val - 1 < p - 1 := fun m _ => by have h1 : (g ^ m).val - 1 + 1 = (g ^ m).val := FRC.Nat.sub_add_cancel (hpos m) have h2 : (g ^ m).val < (p - 1) + 1 := hn ▸ (g ^ m).lt rw [← h1] at h2 exact Nat.lt_of_succ_lt_succ h2 have hinj : ∀ i j, i < p - 1 → j < p - 1 → (g ^ i).val - 1 = (g ^ j).val - 1 → i = j := fun i j hi hj h => by apply F.pow_inj hi hj apply ext rw [← FRC.Nat.sub_add_cancel (hpos i), ← FRC.Nat.sub_add_cancel (hpos j), h] have := sum_perm (fun l => f (ofNat (l + 1))) (fun m => (g ^ m).val - 1) (p - 1) hlt hinj rw [← this] apply sum_congr intro m _ show f (ofNat ((g ^ m).val - 1 + 1)) = f (g ^ m) rw [FRC.Nat.sub_add_cancel (hpos m), ofNat_val] end Frame /-- 00:C1, 20:B10 on `𝔽₁₃`: the frame `(τ; 0, 1, 2)` of capacity `3` — `2` is primitive (decided). Moved here from `Instances.lean` under its name (task LM36), so that the horizon theme takes it without the orbits. -/ theorem frame13 : Frame 13 3 (2 : Shell 13) := ⟨rfl, Nat.zero_lt_succ 2, by decide⟩ end Shell end FRC /-! inlined: FrcCore/Orbit.lean -/ /-! # FrcCore.Orbit — the generators form one orbit (2:B3; 1-algebra's torsor of primitive roots) `Coprime u n` is taken in its invertible form — some `a < n` has `a·u ≡ 1 (mod n)` — which is decidable by search and, for `n ≥ 1`, the same as `gcd(u, n) = 1` (Bezout); it is what every proof uses. Theorem: `h` is primitive of order `n = p − 1` exactly when `h = g^u` with `u < n` coprime to `n`. No axioms. Since the ledger migration (task LM17) it also holds the Klein orbits off the fourth roots of unity (from 1-algebra), the octant character of `2` (from 14-entropy: `2` is a square exactly on the frames of even capacity) and the parity of the drive (from 8-dirac: `g^m` is a square exactly when `m` is even); the parity is `Parity.lean` since task LM24. -/ namespace FRC namespace Shell /-- `u` is invertible mod `n`: some `a < n` has `a·u % n = 1`. -/ def Coprime (u n : Nat) : Prop := ∃ a, a < n ∧ (a * u) % n = 1 instance (u n : Nat) : Decidable (Coprime u n) := decExistsLT (fun a => (a * u) % n = 1) n namespace Frame variable {p : Nat} [Pos p] {κ : Nat} {g : Shell p} /-- A power of the drive with an invertible exponent is again primitive. -/ theorem primitive_pow_of_coprime (F : Frame p κ g) {u : Nat} (hu : Coprime u (p - 1)) : IsPrimitive (g ^ u) (p - 1) := by have hn := F.n_pos match hu with | ⟨a, _, ha⟩ => refine ⟨by rw [pow_mul_comm, F.pow_n, one_pow], ?_⟩ intro l hl hl0 hpow -- (g^u)^l = 1 gives (u·l) % n = 0; with a·u = n·q + 1, g^l = g^{l·a·u} = ((g^u)^l)^a = 1 have h1 : (u * l) % (p - 1) = 0 := F.mod_eq_zero_of_pow_eq_one (by rw [pow_mul]; exact hpow) match FRC.Nat.mod_spec (p - 1) hn (a * u) with | ⟨q, hq⟩ => rw [ha] at hq have e : l * (a * u) = (p - 1) * (q * l) + l := by rw [hq, Nat.left_distrib, Nat.mul_one, FRC.Nat.mul_left_comm, Nat.mul_comm l q] have h2 : g ^ (l * (a * u)) = 1 := by rw [show l * (a * u) = (u * l) * a by rw [Nat.mul_comm u l, FRC.Nat.mul_assoc, Nat.mul_comm a u]] rw [pow_mul, F.pow_eq_one_of_mod h1, one_pow] rw [e, pow_add, pow_mul, F.pow_n, one_pow, one_mul] at h2 have := F.mod_eq_zero_of_pow_eq_one h2 rw [FRC.Nat.mod_eq_of_lt hl] at this exact Nat.lt_irrefl 0 (this ▸ hl0) /-- The frame of another primitive drive on the same shell. -/ theorem of_primitive (F : Frame p κ g) {h : Shell p} (hh : IsPrimitive h (p - 1)) : Frame p κ h := ⟨F.cap, F.cap_pos, hh⟩ /-- 2:B3 (Props. 2.7, 4.5), 1-algebra's torsor — the primitive generators form one orbit: `h` is primitive of order `p − 1` exactly when `h = g^u` for some `u < p − 1` coprime to `p − 1`. -/ theorem generator_orbit (F : Frame p κ g) (h : Shell p) : IsPrimitive h (p - 1) ↔ ∃ u, u < p - 1 ∧ Coprime u (p - 1) ∧ h = g ^ u := by have hn := F.n_pos constructor · intro hh have Fh : Frame p κ h := F.of_primitive hh have hh0 : h ≠ 0 := Fh.g_ne_zero match F.eq_pow_of_ne_zero hh0 with | ⟨u, hu, e⟩ => refine ⟨u, hu, ?_, e.symm⟩ -- g is a power of h: g = h^v; then g^{u v} = g, so u·v ≡ 1 (mod n) match Fh.eq_pow_of_ne_zero F.g_ne_zero with | ⟨v, hv, ev⟩ => refine ⟨v, hv, ?_⟩ have e1 : g ^ (v * u) = g ^ 1 := by rw [pow_one, Nat.mul_comm v u, pow_mul, e, ev] have h1n : 1 < p - 1 := by rw [F.n_eq]; exact Nat.lt_of_lt_of_le (by decide : 1 < 4 * 1) (Nat.mul_le_mul_left 4 F.cap_pos) have := F.pow_inj (Nat.mod_lt _ hn) h1n (by rw [← F.pow_mod, e1]) exact this · intro ⟨u, _, hu, e⟩ rw [e]; exact F.primitive_pow_of_coprime hu /-- 1:E3, the finitary core (Fermat): every residue satisfies `x^p = x` — the polynomial `X^p − X` vanishes on the whole shell, which is what the root test of 1:E3 rests on. -/ theorem fermat (F : Frame p κ g) (x : Shell p) : x ^ p = x := by have hp1 : x ^ p = x ^ (p - 1) * x := congrArg (fun k => x ^ k) (FRC.Nat.sub_add_cancel Pos.pos).symm rw [hp1] exact match Shell.instDecidableEq x 0 with | isTrue e => by rw [e, mul_zero] | isFalse e => by match F.eq_pow_of_ne_zero e with | ⟨m, _, em⟩ => rw [← em, pow_mul_comm, F.pow_n, one_pow, one_mul] /-! ## The Klein orbits off the fourth roots of unity (moved from 1-algebra, task LM17) -/ /-- 1:B2 (Theorem 1 of 1-algebra), 2:D7 — off the fourth roots of unity, `x`, `−x`, `x⁻¹`, `−x⁻¹` are four distinct residues (`y` stands for the inverse: `x·y = 1`). -/ theorem klein_orbit_four (F : Frame p κ g) {x y : Shell p} (hxy : x * y = 1) (h4 : x ^ 4 ≠ 1) : x ≠ -x ∧ x ≠ y ∧ x ≠ -y ∧ -x ≠ y ∧ -x ≠ -y ∧ y ≠ -y := by have hx0 : x ≠ 0 := fun h => F.one_ne_zero (by rw [← hxy, h, zero_mul]) have hy0 : y ≠ 0 := fun h => F.one_ne_zero (by rw [← hxy, h, mul_zero]) have h4' : x ^ 4 = (x * x) * (x * x) := by rw [show (4 : Nat) = 2 * 2 from rfl, pow_mul, pow_two, pow_two] have hsq : x * x ≠ 1 := fun h => h4 (by rw [h4', h, one_mul]) have hsqn : x * x ≠ -1 := fun h => h4 (by rw [h4', h, neg_mul_neg, one_mul]) have hxy' : x = y → False := fun e => hsq (by rw [← hxy, e]) have hxny : x = -y → False := fun e => hsqn (by have : x * x = x * -y := by rw [← e] rw [this, ← mul_neg, hxy]) refine ⟨fun h => hx0 (F.eq_zero_of_eq_neg h), hxy', hxny, ?_, ?_, ?_⟩ · intro h; exact hxny (by rw [← neg_neg x, h]) · intro h; exact hxy' (by rw [← neg_neg x, h, neg_neg]) · intro h; exact hy0 (F.eq_zero_of_eq_neg h) /-! ### 1:B2, the count: the Klein orbits off `Q₄` are exactly `κ − 1`, represented by `g^r`, `1 ≤ r < κ` -/ /-- `y` lies in the Klein orbit of `x`: `y ∈ {x, −x, x⁻¹, −x⁻¹}` (the inverse written as `x·y = 1`). -/ def InOrbit (x y : Shell p) : Prop := y = x ∨ y = -x ∨ x * y = 1 ∨ x * -y = 1 theorem two_mul_eq (κ : Nat) : 2 * κ = κ + κ := Nat.two_mul κ theorem three_mul_eq (κ : Nat) : 3 * κ = κ + κ + κ := by rw [Nat.succ_mul, Nat.two_mul] theorem four_mul_eq (κ : Nat) : 4 * κ = κ + κ + κ + κ := by rw [Nat.succ_mul, three_mul_eq] /-- The exponent `m` of `x = g^m` reduced to its orbit representative in `[1, κ)`. -/ theorem orbit_rep_of_exp (F : Frame p κ g) {m : Nat} (hm : m < p - 1) (h0 : m ≠ 0) (h1 : m ≠ κ) (h2 : m ≠ 2 * κ) (h3 : m ≠ 3 * κ) : ∃ r, 1 ≤ r ∧ r < κ ∧ InOrbit (g ^ r) (g ^ m) := by have hn := F.n_eq have hπ := F.half_period rw [hn, four_mul_eq] at hm rw [two_mul_eq] at h2 hπ rw [three_mul_eq] at h3 match Nat.lt_or_ge m κ with | Or.inl hlt => exact ⟨m, Nat.pos_of_ne_zero h0, hlt, Or.inl rfl⟩ | Or.inr hge1 => match Nat.lt_or_ge m (κ + κ) with | Or.inl hlt => -- κ < m < 2κ: r = 2κ − m, and g^m · (−g^r) = −g^{2κ} = 1 have hgt : κ < m := Nat.lt_of_le_of_ne hge1 (fun e => h1 e.symm) refine ⟨κ + κ - m, ?_, ?_, Or.inr (Or.inr (Or.inr ?_))⟩ · refine Nat.lt_of_add_lt_add_right (n := m) ?_ rw [Nat.zero_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hlt)]; exact hlt · refine Nat.lt_of_add_lt_add_right (n := m) ?_ rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hlt)]; exact Nat.add_lt_add_left hgt κ · rw [← mul_neg, ← pow_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hlt), hπ, neg_neg] | Or.inr hge2 => match Nat.lt_or_ge m (κ + κ + κ) with | Or.inl hlt => -- 2κ < m < 3κ: r = m − 2κ, and g^m = −g^r have hgt : κ + κ < m := Nat.lt_of_le_of_ne hge2 (fun e => h2 e.symm) refine ⟨m - (κ + κ), ?_, ?_, Or.inr (Or.inl ?_)⟩ · refine Nat.lt_of_add_lt_add_right (n := κ + κ) ?_ rw [Nat.zero_add, FRC.Nat.sub_add_cancel hge2]; exact hgt · refine Nat.lt_of_add_lt_add_right (n := κ + κ) ?_ rw [FRC.Nat.sub_add_cancel hge2, Nat.add_comm κ (κ + κ)]; exact hlt · have : m = κ + κ + (m - (κ + κ)) := (FRC.Nat.add_sub_of_le hge2).symm rw [this, pow_add, hπ, neg_one_mul, FRC.Nat.add_sub_cancel_left] | Or.inr hge3 => -- 3κ < m < 4κ: r = 4κ − m, and g^m · g^r = g^{4κ} = 1 have hgt : κ + κ + κ < m := Nat.lt_of_le_of_ne hge3 (fun e => h3 e.symm) refine ⟨κ + κ + κ + κ - m, ?_, ?_, Or.inr (Or.inr (Or.inl ?_))⟩ · refine Nat.lt_of_add_lt_add_right (n := m) ?_ rw [Nat.zero_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hm)]; exact hm · refine Nat.lt_of_add_lt_add_right (n := m) ?_ rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hm), Nat.add_comm κ m] exact Nat.add_lt_add_right hgt κ · rw [← pow_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hm), ← four_mul_eq, ← hn, F.pow_n] /-- Off the fourth roots of unity, `x = g^m` has `m ∉ {0, κ, 2κ, 3κ}`. -/ theorem exp_not_fourth (F : Frame p κ g) {m : Nat} (h4 : (g ^ m) ^ 4 ≠ 1) : m ≠ 0 ∧ m ≠ κ ∧ m ≠ 2 * κ ∧ m ≠ 3 * κ := by have hi := (F.quarter_turn_order).2 refine ⟨fun e => h4 (by rw [e, pow_zero, one_pow]), fun e => h4 (by rw [e, hi]), fun e => h4 ?_, fun e => h4 ?_⟩ · rw [e, Nat.mul_comm 2 κ, pow_mul, ← pow_mul, show (2 : Nat) * 4 = 4 * 2 from rfl, pow_mul, hi, one_pow] · rw [e, Nat.mul_comm 3 κ, pow_mul, ← pow_mul, show (3 : Nat) * 4 = 4 * 3 from rfl, pow_mul, hi, one_pow] /-- 1:B2 (Theorem 1, the count, existence), 2:D7 — every residue off `Q₄` lies in the Klein orbit of some `g^r` with `1 ≤ r < κ`. -/ theorem orbit_rep (F : Frame p κ g) {x : Shell p} (hx : x ≠ 0) (h4 : x ^ 4 ≠ 1) : ∃ r, 1 ≤ r ∧ r < κ ∧ InOrbit (g ^ r) x := by match F.eq_pow_of_ne_zero hx with | ⟨m, hm, e⟩ => rw [← e] at h4 ⊢ match F.exp_not_fourth h4 with | ⟨h0, h1, h2, h3⟩ => exact F.orbit_rep_of_exp hm h0 h1 h2 h3 theorem neg_mul_of_mul_neg {a b : Shell p} (e : a * -b = 1) : -a * b = 1 := by rw [← neg_mul, mul_neg]; exact e /-- The orbit relation is symmetric. -/ theorem inOrbit_symm {a b : Shell p} (h : InOrbit a b) : InOrbit b a := match h with | Or.inl e => Or.inl e.symm | Or.inr (Or.inl e) => Or.inr (Or.inl (by rw [e, neg_neg])) | Or.inr (Or.inr (Or.inl e)) => Or.inr (Or.inr (Or.inl (by rw [mul_comm]; exact e))) | Or.inr (Or.inr (Or.inr e)) => Or.inr (Or.inr (Or.inr (by rw [← mul_neg, mul_comm, mul_neg]; exact e))) theorem neg_eq_neg {a b : Shell p} (h : -a = -b) : a = b := by rw [← neg_neg a, h, neg_neg] /-- The orbit relation is transitive. -/ theorem inOrbit_trans {a b c : Shell p} (h1 : InOrbit a b) (h2 : InOrbit b c) : InOrbit a c := by have hab : b = a ∨ b = -a ∨ a * b = 1 ∨ a * -b = 1 := h1 have hbc : c = b ∨ c = -b ∨ b * c = 1 ∨ b * -c = 1 := h2 unfold InOrbit match hab, hbc with | Or.inl e, h => exact e ▸ h | Or.inr (Or.inl e), Or.inl e' => exact Or.inr (Or.inl (e' ▸ e)) | Or.inr (Or.inl e), Or.inr (Or.inl e') => exact Or.inl (by rw [e', e, neg_neg]) | Or.inr (Or.inl e), Or.inr (Or.inr (Or.inl e')) => exact Or.inr (Or.inr (Or.inr (by rw [← mul_neg, neg_mul, ← e]; exact e'))) | Or.inr (Or.inl e), Or.inr (Or.inr (Or.inr e')) => exact Or.inr (Or.inr (Or.inl (by rw [← neg_mul_neg, ← e]; exact e'))) | Or.inr (Or.inr (Or.inl e)), Or.inl e' => exact Or.inr (Or.inr (Or.inl (e' ▸ e))) | Or.inr (Or.inr (Or.inl e)), Or.inr (Or.inl e') => exact Or.inr (Or.inr (Or.inr (by rw [e', neg_neg]; exact e))) | Or.inr (Or.inr (Or.inl e)), Or.inr (Or.inr (Or.inl e')) => exact Or.inl (inv_unique (x := c) (x' := a) (y := b) (by rw [mul_comm]; exact e') e) | Or.inr (Or.inr (Or.inl e)), Or.inr (Or.inr (Or.inr e')) => exact Or.inr (Or.inl (by have := inv_unique (x := -c) (x' := a) (y := b) (by rw [mul_comm]; exact e') e rw [← this, neg_neg])) | Or.inr (Or.inr (Or.inr e)), Or.inl e' => exact Or.inr (Or.inr (Or.inr (e' ▸ e))) | Or.inr (Or.inr (Or.inr e)), Or.inr (Or.inl e') => exact Or.inr (Or.inr (Or.inl (by rw [e']; exact e))) | Or.inr (Or.inr (Or.inr e)), Or.inr (Or.inr (Or.inl e')) => exact Or.inr (Or.inl (inv_unique (x := -a) (x' := c) (y := b) (neg_mul_of_mul_neg e) (by rw [mul_comm]; exact e')).symm) | Or.inr (Or.inr (Or.inr e)), Or.inr (Or.inr (Or.inr e')) => exact Or.inl (neg_eq_neg (inv_unique (x := -a) (x' := -c) (y := b) (neg_mul_of_mul_neg e) (by rw [mul_comm]; exact e'))).symm /-- The exponents of the orbit of `g^r`: `g^s ∈ orbit(g^r)`, `s < n`, forces `s ∈ {r, r + 2κ, 4κ − r, 2κ − r}` (for `1 ≤ r < κ`). -/ theorem orbit_exponent (F : Frame p κ g) {r s : Nat} (hr1 : 1 ≤ r) (hrκ : r < κ) (hs : s < p - 1) (h : InOrbit (g ^ r) (g ^ s)) : s = r ∨ s = r + (κ + κ) ∨ s = κ + κ + κ + κ - r ∨ s = κ + κ - r := by have hn := F.n_eq have hπ := F.half_period rw [two_mul_eq] at hπ rw [hn, four_mul_eq] at hs have hr2 : r < κ + κ := Nat.lt_of_lt_of_le hrκ (Nat.le_add_right κ κ) have hr4 : r < κ + κ + κ + κ := Nat.lt_of_lt_of_le hr2 (Nat.le_trans (Nat.le_add_right _ κ) (Nat.le_add_right _ κ)) have hpow_inj : ∀ {i j : Nat}, i < κ + κ + κ + κ → j < κ + κ + κ + κ → g ^ i = g ^ j → i = j := fun hi hj e => F.pow_inj (by rw [hn, four_mul_eq]; exact hi) (by rw [hn, four_mul_eq]; exact hj) e have hpn : g ^ (κ + κ + κ + κ) = 1 := by rw [← four_mul_eq, ← hn]; exact F.pow_n match h with | Or.inl e => exact Or.inl (hpow_inj hs hr4 e) | Or.inr (Or.inl e) => have e' : g ^ s = g ^ (r + (κ + κ)) := by rw [e, pow_add, hπ, mul_comm, neg_one_mul] have hlt : r + (κ + κ) < κ + κ + κ + κ := by rw [show κ + κ + κ + κ = (κ + κ) + (κ + κ) by rw [Nat.add_assoc]] exact Nat.add_lt_add_right hr2 _ exact Or.inr (Or.inl (hpow_inj hs hlt e')) | Or.inr (Or.inr (Or.inl e)) => have hlt : κ + κ + κ + κ - r < κ + κ + κ + κ := Nat.sub_lt (Nat.lt_of_lt_of_le (Nat.zero_lt_succ 0) (Nat.le_trans hr1 (Nat.le_of_lt hr4))) hr1 have e2 : g ^ r * g ^ (κ + κ + κ + κ - r) = 1 := by rw [← pow_add, FRC.Nat.add_sub_of_le (Nat.le_of_lt hr4), hpn] have e' : g ^ s = g ^ (κ + κ + κ + κ - r) := F.mul_left_cancel (F.pow_ne_zero r) (e.trans e2.symm) exact Or.inr (Or.inr (Or.inl (hpow_inj hs hlt e'))) | Or.inr (Or.inr (Or.inr e)) => have hlt : κ + κ - r < κ + κ + κ + κ := Nat.lt_of_le_of_lt (Nat.sub_le _ _) (Nat.lt_of_lt_of_le (Nat.lt_add_of_pos_right F.cap_pos) (Nat.le_add_right _ κ)) have e2 : g ^ r * -(g ^ (κ + κ - r)) = 1 := by rw [← mul_neg, ← pow_add, FRC.Nat.add_sub_of_le (Nat.le_of_lt hr2), hπ, neg_neg] have e' : -(g ^ s) = -(g ^ (κ + κ - r)) := F.mul_left_cancel (F.pow_ne_zero r) (e.trans e2.symm) exact Or.inr (Or.inr (Or.inr (hpow_inj hs hlt (neg_eq_neg e')))) /-- 1:B2 (Theorem 1, the count, uniqueness), 2:D7 — two representatives `g^r`, `g^{r'}` with `1 ≤ r, r' < κ` whose orbits meet are the same: the Klein orbits off `Q₄` are exactly `κ − 1`, one for each `r ∈ [1, κ)`. -/ theorem orbit_rep_unique (F : Frame p κ g) {r r' : Nat} (hr1 : 1 ≤ r) (hrκ : r < κ) (_hr1' : 1 ≤ r') (hrκ' : r' < κ) {x : Shell p} (hx : InOrbit (g ^ r) x) (hx' : InOrbit (g ^ r') x) : r = r' := by have hn := F.n_eq have hr' : r' < p - 1 := by rw [hn, four_mul_eq] exact Nat.lt_of_lt_of_le hrκ' (Nat.le_trans (Nat.le_add_right κ κ) (Nat.le_trans (Nat.le_add_right _ κ) (Nat.le_add_right _ κ))) have h := inOrbit_trans hx (inOrbit_symm hx') match F.orbit_exponent hr1 hrκ hr' h with | Or.inl e => exact e.symm | Or.inr (Or.inl e) => exact absurd hrκ' (Nat.not_lt_of_le (by rw [e]; exact Nat.le_trans (Nat.le_add_right κ κ) (Nat.le_add_left _ r))) | Or.inr (Or.inr (Or.inl e)) => -- 4κ − r > κ since r < κ have : κ ≤ κ + κ + κ + κ - r := by apply FRC.Nat.le_sub_of_add_le rw [Nat.add_assoc, Nat.add_assoc] exact Nat.add_le_add_left (Nat.le_trans (Nat.le_of_lt hrκ) (Nat.le_add_right κ _)) κ exact absurd hrκ' (Nat.not_lt_of_le (e ▸ this)) | Or.inr (Or.inr (Or.inr e)) => -- 2κ − r > κ since r < κ have : κ ≤ κ + κ - r := by apply FRC.Nat.le_sub_of_add_le exact Nat.add_le_add_left (Nat.le_of_lt hrκ) κ exact absurd hrκ' (Nat.not_lt_of_le (e ▸ this)) /-! ## The octant character of `2` (moved from 14-entropy, task LM17) -/ /-! ## The octant character on every framed shell of even capacity (14:C6, X4) -/ /-- Literals multiply as their values: `a · b = ab` on every shell. -/ theorem lit_mul (a b : Nat) : (OfNat.ofNat a : Shell p) * OfNat.ofNat b = (OfNat.ofNat (a * b) : Shell p) := Shell.ext (by show (a % p * (b % p)) % p = (a * b) % p exact (FRC.Nat.mul_mod a b p Pos.pos).symm) /-- `a + 1 + (1 − a) = 2` on every shell. -/ theorem add_one_add_one_neg (a : Shell p) : a + 1 + (1 + -a) = 2 := by rw [Shell.add_assoc, ← Shell.add_assoc 1 1 (-a), Shell.add_comm (1 + 1) (-a), ← Shell.add_assoc a (-a) (1 + 1), Shell.add_neg a, Shell.zero_add] exact Frame.two_eq_one_add_one.symm /-- On a frame of capacity `κ = 2m`: `g^{4m} = −1` (the half-period) and `g^{8m} = 1`. -/ theorem even_capacity_powers (F : Frame p κ g) (m : Nat) (hm : κ = 2 * m) : g ^ (4 * m) = -1 ∧ g ^ (8 * m) = 1 := by have h4 : 4 * m = 2 * κ := by rw [hm, ← FRC.Nat.mul_assoc] have h8 : 8 * m = p - 1 := by rw [F.n_eq, hm, ← FRC.Nat.mul_assoc] exact ⟨by rw [h4]; exact F.half_period, by rw [h8]; exact F.pow_n⟩ /-- 14:C6 — the octant character: on every frame `(τ; 0, 1, g)` of even capacity `κ = 2m`, `ζ = g^m` has `ζ⁴ = −1` and `ζ⁸ = 1` — the sector `C₈ ⊂ C_{4κ}` is realised and `ζ` is its residue `ζ₈`. -/ theorem octant_residue (F : Frame p κ g) (m : Nat) (hm : κ = 2 * m) : (g ^ m) ^ 4 = -1 ∧ (g ^ m) ^ 8 = 1 := by obtain ⟨h4, h8⟩ := even_capacity_powers F m hm constructor · rw [← Shell.pow_mul, Nat.mul_comm m 4]; exact h4 · rw [← Shell.pow_mul, Nat.mul_comm m 8]; exact h8 /-- 14:C6, 14:X4 — the Tsirelson square: with `ζ = g^m` and `ζ' = g^{7m}` its inverse (`ζζ' = 1`), `(ζ + ζ')² = 2` and `(2(ζ + ζ'))² = 8` on every frame of capacity `κ = 2m`; hence `2` is a square on every such shell — the direction "octant ⇒ c-square" of X4's second face (the converse is `even_capacity_of_two_square` below; the equivalence `two_is_square_iff`). -/ theorem tsirelson_square (F : Frame p κ g) (m : Nat) (hm : κ = 2 * m) : g ^ m * g ^ (7 * m) = 1 ∧ (g ^ m + g ^ (7 * m)) ^ 2 = 2 ∧ (2 * (g ^ m + g ^ (7 * m))) ^ 2 = 8 := by obtain ⟨h4, h8⟩ := even_capacity_powers F m hm have hz : g ^ m * g ^ (7 * m) = 1 := by rw [← Shell.pow_add, show m + 7 * m = 8 * m by rw [Nat.mul_comm 8 m, Nat.mul_succ, Nat.mul_comm m 7, Nat.add_comm]] exact h8 -- `ζ'² = −ζ²`: `g^{14m} = g^{8m} g^{4m} g^{2m} = (−1) g^{2m}` have h14 : 7 * m + 7 * m = 8 * m + (4 * m + (m + m)) := by calc 7 * m + 7 * m = (7 + 7) * m := (FRC.Nat.add_mul 7 7 m).symm _ = (8 + (4 + (1 + 1))) * m := rfl _ = 8 * m + (4 * m + (1 * m + 1 * m)) := by rw [FRC.Nat.add_mul, FRC.Nat.add_mul, FRC.Nat.add_mul] _ = 8 * m + (4 * m + (m + m)) := by rw [Nat.one_mul] have hz' : g ^ (7 * m) * g ^ (7 * m) = -(g ^ m * g ^ m) := by rw [← Shell.pow_add, h14, Shell.pow_add, Shell.pow_add, Shell.pow_add, h8, h4, Shell.one_mul, Shell.neg_one_mul] -- `(ζ + ζ')² = ζ² + ζζ' + ζ'ζ + ζ'² = ζ² + 1 + (1 − ζ²) = 2` have hsq : (g ^ m + g ^ (7 * m)) ^ 2 = 2 := by rw [Shell.pow_two, Shell.left_distrib, Shell.right_distrib, Shell.right_distrib, hz, Shell.mul_comm (g ^ (7 * m)) (g ^ m), hz, hz'] exact add_one_add_one_neg _ refine ⟨hz, hsq, ?_⟩ rw [Shell.mul_pow, hsq, Shell.pow_two, lit_mul 2 2, lit_mul 4 2] /-- 14:X4 — the direction "even capacity ⇒ `2` a square" at tier 0: on every frame of even capacity `2` is a square, `(ζ + ζ⁻¹)² = 2`; the converse is `even_capacity_of_two_square`, the equivalence `two_is_square_iff`. -/ theorem two_is_square (F : Frame p κ g) (m : Nat) (hm : κ = 2 * m) : ∃ r : Shell p, r * r = 2 := ⟨g ^ m + g ^ (7 * m), by rw [← Shell.pow_two]; exact (tsirelson_square F m hm).2.1⟩ /-! ## The converse: `2` a square ⇒ even capacity, on every frame (14:X4) -/ /-- Literals add as their values: `a + b = (a + b)` on every shell. -/ theorem lit_add (a b : Nat) : (OfNat.ofNat a : Shell p) + OfNat.ofNat b = (OfNat.ofNat (a + b) : Shell p) := Shell.ext (by show (a % p + b % p) % p = (a + b) % p exact (FRC.Nat.add_mod a b p Pos.pos).symm) /-- `−1 ≠ 1` on every frame (`2 ≠ 0`). -/ theorem neg_one_ne_one (F : Frame p κ g) : (-1 : Shell p) ≠ 1 := fun h => by have h2 : (1 : Shell p) + 1 = 0 := by have := Shell.neg_add (1 : Shell p); rw [h] at this; exact this exact F.two_ne_zero (by rw [Frame.two_eq_one_add_one]; exact h2) /-- `−1 ≠ 0` on every frame. -/ theorem neg_one_ne_zero (F : Frame p κ g) : (-1 : Shell p) ≠ 0 := fun h => by have : (1 : Shell p) = 0 := by have h' : -(-1 : Shell p) = -0 := congrArg Neg.neg h rw [Shell.neg_neg, Shell.neg_zero] at h' exact h' exact F.one_ne_zero this /-- A square root of `2` gives a square root of the quarter-turn: with `i² = −1`, `2h = 1` and `r² = 2`, `ζ = (r + i r) h` has `ζ² = i`, hence `ζ⁴ = −1` and `ζ⁸ = 1` — an element of order eight wherever `−1 ≠ 1`, that is on every frame. -/ theorem octant_of_two_square {r i h : Shell p} (hr : r * r = 2) (hi : i * i = -1) (hh : 2 * h = 1) : ∃ ζ : Shell p, ζ * ζ = i ∧ ζ ^ 4 = -1 ∧ ζ ^ 8 = 1 := by -- `(r + i r)² = 4 i` have hA : (r + i * r) * (r + i * r) = i * 4 := by rw [Shell.left_distrib, Shell.right_distrib, Shell.right_distrib, hr, Shell.mul_assoc i r r, hr, Shell.mul_left_comm r i r, hr, Shell.mul_assoc i r (i * r), Shell.mul_left_comm r i r, ← Shell.mul_assoc i i (r * r), hi, hr, Shell.neg_one_mul, Shell.add_comm 2 (i * 2), Shell.add_assoc, Shell.add_comm 2 (i * 2 + -2), Shell.add_assoc, Shell.neg_add, Shell.add_zero, ← Shell.left_distrib, lit_add 2 2] -- `4 h² = (2h)² = 1` have h4 : (4 : Shell p) * (h * h) = 1 := by rw [← lit_mul 2 2, ← mul_mul_mul_comm, hh, Shell.one_mul] have hz : ((r + i * r) * h) * ((r + i * r) * h) = i := by rw [mul_mul_mul_comm, hA, Shell.mul_assoc, h4, Shell.mul_one] refine ⟨(r + i * r) * h, hz, ?_, ?_⟩ · rw [show (4 : Nat) = 2 * 2 from rfl, Shell.pow_mul, Shell.pow_two, Shell.pow_two, hz, hi] · rw [show (8 : Nat) = 2 * 2 * 2 from rfl, Shell.pow_mul, Shell.pow_mul, Shell.pow_two, Shell.pow_two, Shell.pow_two, hz, hi, Shell.neg_mul_neg, Shell.one_mul] /-- The arithmetic of the order: `(k · 8) % 4κ = 0` and `(k · 4) % 4κ ≠ 0` force `κ` even (a divisor `4κ` of `8k` that misses `4k` cannot be `4 · odd`; `0 < κ` is only what `mod_spec` needs). -/ theorem even_of_order_eight {κ k : Nat} (hκ : 0 < κ) (h8 : (k * 8) % (4 * κ) = 0) (h4 : (k * 4) % (4 * κ) ≠ 0) : ∃ m, κ = 2 * m := by have h4κ : 0 < 4 * κ := Nat.mul_pos (Nat.zero_lt_succ 3) hκ obtain ⟨q, hq⟩ := FRC.Nat.mod_spec (4 * κ) h4κ (k * 8) rw [h8, Nat.add_zero] at hq -- `2k = κ q` have h2k : 2 * k = κ * q := by apply Nat.eq_of_mul_eq_mul_left (Nat.zero_lt_succ 3) rw [← FRC.Nat.mul_assoc, ← FRC.Nat.mul_assoc, Nat.mul_comm 4 2, Nat.mul_comm (2 * 4) k, ← hq] have h2 : 0 < 2 := Nat.zero_lt_succ 1 obtain ⟨m, hm⟩ := FRC.Nat.mod_spec 2 h2 κ have hlt : κ % 2 < 2 := FRC.Nat.mod_lt' κ h2 match hκ2 : κ % 2 with | 0 => rw [hκ2, Nat.add_zero] at hm; exact ⟨m, hm⟩ | 1 => -- `κ` odd: `q` is even, `k = κ q'`, so `4κ ∣ 4k`, contradicting `h4` have hq2 : q % 2 = 0 := by have e1 : (κ * q) % 2 = q % 2 := by rw [FRC.Nat.mul_mod κ q 2 h2, hκ2, Nat.one_mul, FRC.Nat.mod_mod q 2 h2] have e2 : (2 * k) % 2 = 0 := by rw [Nat.mul_comm 2 k] exact (FRC.Nat.mod_unique (Nat.zero_lt_succ 1) (by rw [Nat.add_zero, Nat.mul_comm k 2]) : (k * 2) % 2 = 0) rw [← e1, ← h2k]; exact e2 obtain ⟨q', hq'⟩ := FRC.Nat.mod_spec 2 h2 q rw [hq2, Nat.add_zero] at hq' have hk : k = κ * q' := by apply Nat.eq_of_mul_eq_mul_left h2 rw [h2k, hq', Nat.mul_left_comm κ 2 q'] exact absurd (FRC.Nat.mod_unique h4κ (by rw [hk, Nat.add_zero, Nat.mul_comm (κ * q') 4, ← FRC.Nat.mul_assoc])) h4 | n + 2 => exact absurd hlt (by rw [hκ2]; exact Nat.not_lt_of_ge (Nat.le_add_left 2 n)) /-- 14:C6 — the octant forces even capacity: on every frame, an element `ζ` with `ζ⁴ = −1` and `ζ⁸ = 1` (an element of order eight) gives `8 ∣ 4κ`, so the capacity is even. -/ theorem even_capacity_of_octant (F : Frame p κ g) {ζ : Shell p} (hz4 : ζ ^ 4 = -1) (hz8 : ζ ^ 8 = 1) : ∃ m, κ = 2 * m := by have hζ0 : ζ ≠ 0 := fun h0 => by rw [h0, show (4 : Nat) = 3 + 1 from rfl, Shell.pow_succ, Shell.mul_zero] at hz4 exact neg_one_ne_zero F hz4.symm obtain ⟨k, hk, hgk⟩ := F.eq_pow_of_ne_zero hζ0 have e8 : (k * 8) % (p - 1) = 0 := F.mod_eq_zero_of_pow_eq_one (by rw [Shell.pow_mul, hgk]; exact hz8) have e4 : (k * 4) % (p - 1) ≠ 0 := fun e => by have := F.pow_eq_one_of_mod e rw [Shell.pow_mul, hgk, hz4] at this exact neg_one_ne_one F this rw [F.n_eq] at e8 e4 exact even_of_order_eight F.cap_pos e8 e4 /-- 14:C6 — the octant sector at tier 0, as an equivalence: on every frame, an element with `ζ⁴ = −1` and `ζ⁸ = 1` exists exactly when the capacity is even. -/ theorem octant_iff (F : Frame p κ g) : (∃ ζ : Shell p, ζ ^ 4 = -1 ∧ ζ ^ 8 = 1) ↔ ∃ m, κ = 2 * m := ⟨fun ⟨_, h4, h8⟩ => even_capacity_of_octant F h4 h8, fun ⟨m, hm⟩ => ⟨g ^ m, octant_residue F m hm⟩⟩ /-- 14:X4 — the converse of the second face at tier 0: on every frame, a square root of `2` forces the capacity even — `ζ = (r + i r)/2` has `ζ² = i`, so an element of order eight exists and `8 ∣ 4κ`. -/ theorem even_capacity_of_two_square (F : Frame p κ g) {r : Shell p} (hr : r * r = 2) : ∃ m, κ = 2 * m := by obtain ⟨h, hh⟩ := F.exists_inv F.two_ne_zero obtain ⟨ζ, _, hz4, hz8⟩ := octant_of_two_square hr F.quarter_turn_sq hh exact even_capacity_of_octant F hz4 hz8 /-- 14:X4 — the second face as an equivalence at tier 0: on every frame `(τ; 0, 1, g)`, `2` is a square exactly when the capacity is even — the c-square congruence and the octant sector are one condition. -/ theorem two_is_square_iff (F : Frame p κ g) : (∃ r : Shell p, r * r = 2) ↔ ∃ m, κ = 2 * m := ⟨fun ⟨_, hr⟩ => even_capacity_of_two_square F hr, fun ⟨m, hm⟩ => two_is_square F m hm⟩ end Frame end Shell end FRC /-! inlined: FrcCore/Sum.lean -/ /-! # FrcCore.Sum — finite sums on the shell, the geometric sum, the Fourier inversion Sums over `l < n` are defined by structural recursion (`sumRange f (n+1) = sumRange f n + f n`): no `Finset`, no quotient, no function extensionality — a congruence lemma (`sum_congr`) replaces `funext`. The geometric sum gives the principal-root identity (2:F1, Prop. 6.1 of 2-geometry) and the entrywise inversion of the shell Fourier matrix `W k j = g^{jk}`: `Σ_l W k l · (−g^{−lj}) = [k = j]` (2:F3, Prop. 6.3; 6:B5 in matrix form). No axioms. Since the ledger migration (task LM17) it also holds 20-rh's sums: peeling the first term, and the sum over the nonzero residues reindexed by the drive. Since task LM22 the sums that need no frame (`sumRange` and its lemmas, the geometric sum, the sums over lists and `sum_perm`) are in `Series.lean`, under their names; this module keeps the frame's: the principal root, the Fourier inversion, the reversal and the eigenspaces. Since task LM25 the transform (the principal root, the inversion, `rev`, `W`, `J`, `F` and their products) is in `Transform.lean`, names unchanged, and since task LM36 the reindexing by the drive (`sum_units_eq_sum_pow`) is there too. -/ namespace FRC namespace Shell variable {p : Nat} [Pos p] namespace Frame variable {κ : Nat} {g : Shell p} /-- The shell Fourier transform of `v` at `k`: `Σ_{j v j * g ^ (j * k)) n /-- The polynomial `P_v(x) = Σ_{j v j * x ^ j) n /-- 2:F4 (Prop. 6.5) — the polynomial reading: `F_g(v)_k = P_v(g^k)`. -/ theorem dft_eq_polyEval (g : Shell p) (n : Nat) (v : Nat → Shell p) (k : Nat) : dft g n v k = polyEval n v (g ^ k) := by unfold dft polyEval apply sum_congr; intro j _ rw [Nat.mul_comm j k, pow_mul] /-- The reindexing `j ↦ u·j mod n` is injective on `[0, n)` when `u` is invertible mod `n`. -/ theorem mul_mod_inj (F : Frame p κ g) {u : Nat} (hu : Coprime u (p - 1)) {i j : Nat} (hi : i < p - 1) (hj : j < p - 1) (h : (u * i) % (p - 1) = (u * j) % (p - 1)) : i = j := by have hn := F.n_pos match hu with | ⟨a, _, ha⟩ => have key : ∀ i, i < p - 1 → (a * (u * i)) % (p - 1) = i := by intro i hi match FRC.Nat.mod_spec (p - 1) hn (a * u) with | ⟨q, hq⟩ => rw [ha] at hq rw [← FRC.Nat.mul_assoc, hq, FRC.Nat.add_mul, Nat.one_mul, FRC.Nat.mul_assoc, FRC.Nat.add_mul_mod_self_left _ _ _ hn, FRC.Nat.mod_eq_of_lt hi] rw [← key i hi, ← key j hj, ← FRC.Nat.mul_mod_mod _ _ _ hn, h, FRC.Nat.mul_mod_mod _ _ _ hn] /-- 2:F5 (Prop. 6.7) — covariance under generator change: for `g' = g^u` (`u` invertible mod `n`) and `v'_j = v_{u·j mod n}`, `F_{g'}(v')_k = F_g(v)_k`. -/ theorem dft_covariance (F : Frame p κ g) {u : Nat} (hu : Coprime u (p - 1)) (v : Nat → Shell p) (k : Nat) : dft (g ^ u) (p - 1) (fun j => v ((u * j) % (p - 1))) k = dft g (p - 1) v k := by have hn := F.n_pos unfold dft have e : ∀ j, v ((u * j) % (p - 1)) * (g ^ u) ^ (j * k) = v ((u * j) % (p - 1)) * g ^ (((u * j) % (p - 1)) * k) := by intro j rw [← pow_mul, F.pow_mod (u * (j * k)), F.pow_mod (((u * j) % (p - 1)) * k), FRC.Nat.mod_mul_mod _ _ _ hn, ← FRC.Nat.mul_assoc] rw [sum_congr _ (fun j _ => e j)] exact sum_perm (fun l => v l * g ^ (l * k)) (fun j => (u * j) % (p - 1)) (p - 1) (fun j _ => Nat.mod_lt _ hn) (fun i j hi hj h => F.mul_mod_inj hu hi hj h) /-! ### 6:B7 — the eigenspaces of the reversal: `V = V⁺ ⊕ V⁻`, `dim V⁺ = 2κ + 1`, `dim V⁻ = 2κ − 1` -/ /-- `v` is symmetric under the reversal: `v (rev k) = v k` for `k < n`. -/ def Symm (n : Nat) (v : Nat → Shell p) : Prop := ∀ k, k < n → v (rev n k) = v k /-- `v` is antisymmetric under the reversal: `v (rev k) = −v k` for `k < n`. -/ def Antisymm (n : Nat) (v : Nat → Shell p) : Prop := ∀ k, k < n → v (rev n k) = -(v k) theorem rev_eq_sub {n k : Nat} (hk : k < n) (hk0 : 0 < k) : rev n k = n - k := rev_of_pos hk hk0 /-- 6:B7 — a symmetric vector is determined by its `2κ + 1` coordinates `v 0, …, v (2κ)`. -/ theorem symm_determined (F : Frame p κ g) {v w : Nat → Shell p} (hv : Symm (p - 1) v) (hw : Symm (p - 1) w) (h : ∀ k, k ≤ 2 * κ → v k = w k) : ∀ k, k < p - 1 → v k = w k := by intro k hk exact match Nat.lt_or_ge k (2 * κ + 1) with | Or.inl hlt => h k (Nat.le_of_lt_succ hlt) | Or.inr hge => -- k > 2κ: rev k = n − k ≤ 2κ − 1 have hk0 : 0 < k := Nat.lt_of_lt_of_le (Nat.zero_lt_succ _) hge have hr : rev (p - 1) k ≤ 2 * κ := by rw [rev_eq_sub hk hk0] apply FRC.Nat.sub_le_of_le_add rw [← F.four_kappa] exact Nat.add_le_add_left (Nat.le_of_lt hge) _ calc v k = v (rev (p - 1) k) := (hv k hk).symm _ = w (rev (p - 1) k) := h _ hr _ = w k := hw k hk /-- 6:B7 — every assignment of the `2κ + 1` coordinates extends to a symmetric vector. -/ theorem symm_extend (F : Frame p κ g) (c : Nat → Shell p) : ∃ v : Nat → Shell p, Symm (p - 1) v ∧ ∀ k, k ≤ 2 * κ → v k = c k := by refine ⟨fun k => if k ≤ 2 * κ then c k else c (rev (p - 1) k), ?_, fun k hk => by show (if k ≤ 2 * κ then c k else c (rev (p - 1) k)) = c k rw [ite_eq_left hk]⟩ intro k hk show (if rev (p - 1) k ≤ 2 * κ then c (rev (p - 1) k) else c (rev (p - 1) (rev (p - 1) k))) = (if k ≤ 2 * κ then c k else c (rev (p - 1) k)) rw [rev_rev hk] exact match Nat.decLe k (2 * κ), Nat.decLe (rev (p - 1) k) (2 * κ) with | isTrue h1, isTrue h2 => by rw [ite_eq_left h1, ite_eq_left h2] -- both k and n − k are ≤ 2κ: k = 0 (rev 0 = 0) or k = 2κ (rev = 2κ) exact match Nat.decEq k 0 with | isTrue e => by rw [e, rev_zero _ F.n_pos] | isFalse e => by have hk0 := Nat.pos_of_ne_zero e rw [rev_eq_sub hk hk0] at h2 ⊢ -- n − k ≤ 2κ and k ≤ 2κ force k = 2κ have h3 : p - 1 ≤ 2 * κ + k := FRC.Nat.le_add_of_sub_le (Nat.le_of_lt hk) h2 rw [← F.four_kappa] at h3 have hk2 : k = 2 * κ := Nat.le_antisymm h1 (FRC.Nat.le_of_add_le_add_left h3) rw [hk2, ← F.four_kappa, FRC.Nat.add_sub_cancel] | isTrue h1, isFalse h2 => by rw [ite_eq_left h1, ite_eq_right h2] | isFalse h1, isTrue h2 => by rw [ite_eq_right h1, ite_eq_left h2] | isFalse h1, isFalse h2 => by rw [ite_eq_right h1, ite_eq_right h2] -- impossible: k > 2κ and n − k > 2κ would give n > 4κ exact absurd (by have hk0 : 0 < k := Nat.lt_of_lt_of_le (Nat.zero_lt_succ _) (Nat.lt_of_not_le h1) rw [rev_eq_sub hk hk0] at h2 have a1 := Nat.lt_of_not_le h1 have a2 := Nat.lt_of_not_le h2 have := Nat.add_lt_add a1 a2 rw [FRC.Nat.add_sub_of_le (Nat.le_of_lt hk), F.four_kappa] at this exact this) (Nat.lt_irrefl _) /-- 6:B7 — an antisymmetric vector vanishes at the two fixed points of the reversal, `0` and `2κ`. -/ theorem antisymm_fixed (F : Frame p κ g) {v : Nat → Shell p} (hv : Antisymm (p - 1) v) : v 0 = 0 ∧ v (2 * κ) = 0 := by have hn := F.n_pos have h0 : v 0 = -(v 0) := by rw [← hv 0 hn, rev_zero _ hn] have h2 : v (2 * κ) = -(v (2 * κ)) := by rw [← hv (2 * κ) F.two_kappa_lt, rev_eq_sub F.two_kappa_lt F.two_kappa_pos, ← F.four_kappa, FRC.Nat.add_sub_cancel] exact ⟨F.eq_zero_of_eq_neg h0, F.eq_zero_of_eq_neg h2⟩ /-- 6:B7 — an antisymmetric vector is determined by its `2κ − 1` coordinates `v 1, …, v (2κ − 1)`. -/ theorem antisymm_determined (F : Frame p κ g) {v w : Nat → Shell p} (hv : Antisymm (p - 1) v) (hw : Antisymm (p - 1) w) (h : ∀ k, 0 < k → k < 2 * κ → v k = w k) : ∀ k, k < p - 1 → v k = w k := by intro k hk exact match Nat.decEq k 0 with | isTrue e => by rw [e, (F.antisymm_fixed hv).1, (F.antisymm_fixed hw).1] | isFalse e0 => match Nat.decEq k (2 * κ) with | isTrue e => by rw [e, (F.antisymm_fixed hv).2, (F.antisymm_fixed hw).2] | isFalse e2 => match Nat.lt_or_ge k (2 * κ) with | Or.inl hlt => h k (Nat.pos_of_ne_zero e0) hlt | Or.inr hge => have hgt : 2 * κ < k := Nat.lt_of_le_of_ne hge (fun e => e2 e.symm) have hk0 : 0 < k := Nat.lt_of_lt_of_le F.two_kappa_pos hge have hr1 : 0 < rev (p - 1) k := by rw [rev_eq_sub hk hk0] refine Nat.lt_of_add_lt_add_right (n := k) ?_ rw [Nat.zero_add, FRC.Nat.sub_add_cancel (Nat.le_of_lt hk)]; exact hk have hr2 : rev (p - 1) k < 2 * κ := by rw [rev_eq_sub hk hk0] refine Nat.lt_of_add_lt_add_right (n := k) ?_ rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hk), ← F.four_kappa] exact Nat.add_lt_add_left hgt _ calc v k = -(-(v k)) := (neg_neg _).symm _ = -(v (rev (p - 1) k)) := by rw [hv k hk] _ = -(w (rev (p - 1) k)) := by rw [h _ hr1 hr2] _ = -(-(w k)) := by rw [hw k hk] _ = w k := neg_neg _ /-- 6:B7 — every assignment of the `2κ − 1` inner coordinates extends to an antisymmetric vector. -/ theorem antisymm_extend (F : Frame p κ g) (c : Nat → Shell p) : ∃ v : Nat → Shell p, Antisymm (p - 1) v ∧ ∀ k, 0 < k → k < 2 * κ → v k = c k := by refine ⟨fun k => if k = 0 then 0 else if k = 2 * κ then 0 else if k < 2 * κ then c k else -(c (rev (p - 1) k)), ?_, fun k hk0 hk2 => by show (if k = 0 then 0 else if k = 2 * κ then 0 else if k < 2 * κ then c k else -(c (rev (p - 1) k))) = c k rw [ite_eq_right (Nat.ne_of_gt hk0), ite_eq_right (Nat.ne_of_lt hk2), ite_eq_left hk2]⟩ intro k hk have hn := F.n_pos show (if rev (p - 1) k = 0 then 0 else if rev (p - 1) k = 2 * κ then 0 else if rev (p - 1) k < 2 * κ then c (rev (p - 1) k) else -(c (rev (p - 1) (rev (p - 1) k)))) = -(if k = 0 then 0 else if k = 2 * κ then 0 else if k < 2 * κ then c k else -(c (rev (p - 1) k))) match Nat.decEq k 0 with | isTrue e => rw [e, rev_zero _ hn, ite_eq_left rfl, ite_eq_left rfl, neg_zero] | isFalse e0 => have hk0 := Nat.pos_of_ne_zero e0 have hrk : rev (p - 1) k = p - 1 - k := rev_eq_sub hk hk0 have hr0 : rev (p - 1) k ≠ 0 := fun h => by rw [hrk] at h have := FRC.Nat.sub_add_cancel (Nat.le_of_lt hk) rw [h, Nat.zero_add] at this exact Nat.lt_irrefl _ (this ▸ hk) match Nat.decEq k (2 * κ) with | isTrue e => have : rev (p - 1) k = 2 * κ := by rw [hrk, e, ← F.four_kappa, FRC.Nat.add_sub_cancel] rw [ite_eq_right hr0, ite_eq_left this, ite_eq_right e0, ite_eq_left e, neg_zero] | isFalse e2 => have hr2 : rev (p - 1) k ≠ 2 * κ := fun h => e2 (by have := rev_rev hk rw [h] at this rw [← this, rev_eq_sub F.two_kappa_lt F.two_kappa_pos, ← F.four_kappa, FRC.Nat.add_sub_cancel]) rw [ite_eq_right hr0, ite_eq_right hr2, ite_eq_right e0, ite_eq_right e2] match Nat.lt_or_ge k (2 * κ) with | Or.inl hlt => have hge : ¬ rev (p - 1) k < 2 * κ := fun h => by rw [hrk] at h have := Nat.add_lt_add h hlt rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hk), F.four_kappa] at this exact Nat.lt_irrefl _ this rw [ite_eq_right hge, ite_eq_left hlt, rev_rev hk] | Or.inr hge => have hlt' : ¬ k < 2 * κ := Nat.not_lt_of_le hge have hgt : 2 * κ < k := Nat.lt_of_le_of_ne hge (fun e => e2 e.symm) have hr : rev (p - 1) k < 2 * κ := by rw [hrk] refine Nat.lt_of_add_lt_add_right (n := k) ?_ rw [FRC.Nat.sub_add_cancel (Nat.le_of_lt hk), ← F.four_kappa] exact Nat.add_lt_add_left hgt _ rw [ite_eq_left hr, ite_eq_right hlt', neg_neg] /-- 6:B7 — the decomposition `V = V⁺ ⊕ V⁻`: with `h = 2⁻¹`, `v = v⁺ + v⁻` where `v⁺ k = h(v k + v (rev k))` is symmetric and `v⁻ k = h(v k − v (rev k))` antisymmetric; the decomposition is unique. -/ theorem symm_antisymm_decomp (F : Frame p κ g) (v : Nat → Shell p) : ∃ vp vm : Nat → Shell p, Symm (p - 1) vp ∧ Antisymm (p - 1) vm ∧ ∀ k, k < p - 1 → v k = vp k + vm k := by match F.exists_inv F.two_ne_zero with | ⟨h, hh⟩ => refine ⟨fun k => h * (v k + v (rev (p - 1) k)), fun k => h * (v k + -(v (rev (p - 1) k))), ?_, ?_, ?_⟩ · intro k hk; show h * (v (rev (p - 1) k) + v (rev (p - 1) (rev (p - 1) k))) = h * (v k + v (rev (p - 1) k)) rw [rev_rev hk, add_comm] · intro k hk; show h * (v (rev (p - 1) k) + -(v (rev (p - 1) (rev (p - 1) k)))) = -(h * (v k + -(v (rev (p - 1) k)))) rw [rev_rev hk, mul_neg, neg_add_rev, neg_neg, add_comm] · intro k _ show v k = h * (v k + v (rev (p - 1) k)) + h * (v k + -(v (rev (p - 1) k))) rw [← left_distrib, add_add_add_comm, add_neg, add_zero, ← two_mul', ← mul_assoc, mul_comm h, hh, one_mul] /-- 6:B7 — the decomposition is unique: a vector that is both symmetric and antisymmetric is zero, so the symmetric and antisymmetric parts of `v` are determined. -/ theorem symm_antisymm_unique (F : Frame p κ g) {a b : Nat → Shell p} (ha : Symm (p - 1) a) (hb : Antisymm (p - 1) b) (h : ∀ k, k < p - 1 → a k + b k = 0) : ∀ k, k < p - 1 → a k = 0 ∧ b k = 0 := by intro k hk have h1 := h k hk have h2 := h (rev (p - 1) k) (rev_lt F.n_pos k) rw [ha k hk, hb k hk] at h2 -- a k + b k = 0 and a k − b k = 0 give 2 a k = 0 have ha0 : a k = 0 := F.no_south_pole _ (by rw [two_mul'] calc a k + a k = (a k + b k) + (a k + -(b k)) := by rw [add_add_add_comm, add_neg, add_zero] _ = 0 := by rw [h1, h2, add_zero]) refine ⟨ha0, ?_⟩ rw [ha0, zero_add] at h1; exact h1 end Frame end Shell end FRC /-! inlined: FrcCore/Theme/Logic.lean -/ /-! # FrcCore.Theme.Logic — the bounded language over a finite structure and its counting (the logic theme, task LM17) An explicit language of `Δ₀` formulas with two evaluators, over `ℕ` and in a frame `W_N` where overflow makes an atom false, and the bounded stability schema: every formula takes its standard value in every frame above its bound (5:B6). The counting behind the paradoxes of infinity and finite Gödel: fewer than `s^(K+1)` records of length `≤ K` and no mirror of a larger frame (5:C2; `no_mirror` is in the base's `Series.lean` since task LM23); an iteration on `n` states repeats within `n` steps (5:C5, 5:E5); Cantor on the finite frame (5:D3); the least element (5:E1, 5:E2); on a finite carrier an injective map is onto, a part with fewer states identifies two elements, `m + 1` sentences outnumber `m` elements (25:C1, 25:C5, 25:D1); the count of a Boolean predicate; dense codings need `a^n ≤ m^k` (25:F4). Moved from 5-reductio and 25-godel, whose modules keep every old name. No axioms. -/ namespace FRC.Logic /-! ### the maximum, from its definition -/ /-- `mx a b`, the larger of two naturals, with its two bounds proved from the definition. -/ def mx (a b : Nat) : Nat := if a ≤ b then b else a theorem le_mx_left (a b : Nat) : a ≤ mx a b := by unfold mx match Nat.decLe a b with | isTrue h => rw [ite_eq_left h]; exact h | isFalse h => rw [ite_eq_right h]; exact Nat.le_refl a theorem le_mx_right (a b : Nat) : b ≤ mx a b := by unfold mx match Nat.decLe a b with | isTrue h => rw [ite_eq_left h]; exact Nat.le_refl b | isFalse h => rw [ite_eq_right h]; exact Nat.le_of_lt (Nat.lt_of_not_le h) theorem lt_of_mx_lt_left {a b N : Nat} (h : mx a b < N) : a < N := Nat.lt_of_le_of_lt (le_mx_left a b) h theorem lt_of_mx_lt_right {a b N : Nat} (h : mx a b < N) : b < N := Nat.lt_of_le_of_lt (le_mx_right a b) h /-! ### 5:B6 — the bounded stability schema for an explicit `Δ₀` language -/ /-- Terms: variables (de Bruijn indices), `0`, `1`, sum, product. -/ inductive Term where | var : Nat → Term | zero : Term | one : Term | add : Term → Term → Term | mul : Term → Term → Term /-- `Δ₀` formulas: atoms `s = t`, `s < t`, negation, conjunction, and the bounded quantifier `∀ x ≤ t, φ` (`x` is variable `0` in `φ`, the other variables shift up; `t` is read in the outer environment). -/ inductive Form where | eq : Term → Term → Form | lt : Term → Term → Form | neg : Form → Form | conj : Form → Form → Form | ball : Term → Form → Form /-- The environment extended by a value for variable `0`. -/ def cons (x : Nat) (env : Nat → Nat) : Nat → Nat | 0 => x | i + 1 => env i /-- Terms over `ℕ`. -/ def evalT (env : Nat → Nat) : Term → Nat | .var i => env i | .zero => 0 | .one => 1 | .add s t => evalT env s + evalT env t | .mul s t => evalT env s * evalT env t /-- `f 0 && … && f (n − 1)`. -/ def allBelow (f : Nat → Bool) : Nat → Bool | 0 => true | n + 1 => f n && allBelow f n /-- Formulas over `ℕ` (the standard value). -/ def evalF (env : Nat → Nat) : Form → Bool | .eq s t => decide (evalT env s = evalT env t) | .lt s t => decide (evalT env s < evalT env t) | .neg φ => !(evalF env φ) | .conj φ ψ => evalF env φ && evalF env ψ | .ball t φ => allBelow (fun x => evalF (cons x env) φ) (evalT env t + 1) /-- Terms in the frame `W_N`: a value is defined only while every intermediate value stays below `N` (overflow: `A(x, y, z)` fails for `x + y ≥ N`). -/ def evalT? (N : Nat) (env : Nat → Nat) : Term → Option Nat | .var i => if env i < N then some (env i) else none | .zero => if 0 < N then some 0 else none | .one => if 1 < N then some 1 else none | .add s t => match evalT? N env s, evalT? N env t with | some a, some b => if a + b < N then some (a + b) else none | some _, none => none | none, some _ => none | none, none => none | .mul s t => match evalT? N env s, evalT? N env t with | some a, some b => if a * b < N then some (a * b) else none | some _, none => none | none, some _ => none | none, none => none /-- Formulas in the frame `W_N`: an atom with an undefined term is false, a bounded quantifier is guarded by the definedness of its bound (the transcription `φ*` of the paper). -/ def evalF? (N : Nat) (env : Nat → Nat) : Form → Bool | .eq s t => match evalT? N env s, evalT? N env t with | some a, some b => decide (a = b) | some _, none => false | none, some _ => false | none, none => false | .lt s t => match evalT? N env s, evalT? N env t with | some a, some b => decide (a < b) | some _, none => false | none, some _ => false | none, none => false | .neg φ => !(evalF? N env φ) | .conj φ ψ => evalF? N env φ && evalF? N env ψ | .ball t φ => match evalT? N env t with | some b => allBelow (fun x => evalF? N (cons x env) φ) (b + 1) | none => false /-- The largest value a term's evaluation touches. -/ def boundT (env : Nat → Nat) : Term → Nat | .var i => env i | .zero => 0 | .one => 1 | .add s t => mx (mx (boundT env s) (boundT env t)) (evalT env s + evalT env t) | .mul s t => mx (mx (boundT env s) (boundT env t)) (evalT env s * evalT env t) /-- `max (f 0, …, f (n − 1))`. -/ def maxBelow (f : Nat → Nat) : Nat → Nat | 0 => 0 | n + 1 => mx (f n) (maxBelow f n) /-- `t(φ)`, the largest integer referenced in the evaluation of `φ` over `ℕ`. -/ def boundF (env : Nat → Nat) : Form → Nat | .eq s t => mx (boundT env s) (boundT env t) | .lt s t => mx (boundT env s) (boundT env t) | .neg φ => boundF env φ | .conj φ ψ => mx (boundF env φ) (boundF env ψ) | .ball t φ => mx (boundT env t) (maxBelow (fun x => boundF (cons x env) φ) (evalT env t + 1)) theorem le_maxBelow (f : Nat → Nat) : ∀ {n x : Nat}, x < n → f x ≤ maxBelow f n | 0, x, hx => absurd hx (Nat.not_lt_zero x) | n + 1, x, hx => match Nat.decEq x n with | isTrue e => by rw [e]; exact le_mx_left _ _ | isFalse e => have hlt : x < n := Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hx) e Nat.le_trans (le_maxBelow f hlt) (le_mx_right _ _) theorem allBelow_congr {f g : Nat → Bool} : ∀ {n : Nat}, (∀ x, x < n → f x = g x) → allBelow f n = allBelow g n | 0, _ => rfl | n + 1, h => by show (f n && allBelow f n) = (g n && allBelow g n) rw [h n (Nat.lt_succ_self n), allBelow_congr (fun x hx => h x (Nat.lt_succ_of_lt hx))] /-- 5:B6 (terms) — below its bound a term is defined in the frame, with its standard value. -/ theorem evalT_frame (N : Nat) (env : Nat → Nat) : ∀ (t : Term), boundT env t < N → evalT? N env t = some (evalT env t) | .var i, h => by have h' : env i < N := h show (if env i < N then some (env i) else none) = some (env i); rw [ite_eq_left h'] | .zero, h => by have h' : 0 < N := h show (if 0 < N then some 0 else none) = some 0; rw [ite_eq_left h'] | .one, h => by have h' : 1 < N := h show (if 1 < N then some 1 else none) = some 1; rw [ite_eq_left h'] | .add s t, h => by have hs := evalT_frame N env s (lt_of_mx_lt_left (lt_of_mx_lt_left h)) have ht := evalT_frame N env t (lt_of_mx_lt_right (lt_of_mx_lt_left h)) show (match evalT? N env s, evalT? N env t with | some a, some b => if a + b < N then some (a + b) else none | some _, none => none | none, some _ => none | none, none => none) = some (evalT env s + evalT env t) rw [hs, ht] show (if evalT env s + evalT env t < N then some (evalT env s + evalT env t) else none) = some (evalT env s + evalT env t) rw [ite_eq_left (lt_of_mx_lt_right h)] | .mul s t, h => by have hs := evalT_frame N env s (lt_of_mx_lt_left (lt_of_mx_lt_left h)) have ht := evalT_frame N env t (lt_of_mx_lt_right (lt_of_mx_lt_left h)) show (match evalT? N env s, evalT? N env t with | some a, some b => if a * b < N then some (a * b) else none | some _, none => none | none, some _ => none | none, none => none) = some (evalT env s * evalT env t) rw [hs, ht] show (if evalT env s * evalT env t < N then some (evalT env s * evalT env t) else none) = some (evalT env s * evalT env t) rw [ite_eq_left (lt_of_mx_lt_right h)] /-- 5:B6, 29:E2, 29:X2 (Theorem stability, schema form) — every `Δ₀` formula takes its standard value in every frame `W_N` with `N > t(φ)`: `W_N ⊨ φ* ⟺ ℕ ⊨ φ`, for every environment, by induction on the formula. -/ theorem stable (N : Nat) : ∀ (φ : Form) (env : Nat → Nat), boundF env φ < N → evalF? N env φ = evalF env φ | .eq s t, env, h => by show (match evalT? N env s, evalT? N env t with | some a, some b => decide (a = b) | some _, none => false | none, some _ => false | none, none => false) = decide (evalT env s = evalT env t) rw [evalT_frame N env s (lt_of_mx_lt_left h), evalT_frame N env t (lt_of_mx_lt_right h)] | .lt s t, env, h => by show (match evalT? N env s, evalT? N env t with | some a, some b => decide (a < b) | some _, none => false | none, some _ => false | none, none => false) = decide (evalT env s < evalT env t) rw [evalT_frame N env s (lt_of_mx_lt_left h), evalT_frame N env t (lt_of_mx_lt_right h)] | .neg φ, env, h => by show (!(evalF? N env φ)) = !(evalF env φ) rw [stable N φ env h] | .conj φ ψ, env, h => by show (evalF? N env φ && evalF? N env ψ) = (evalF env φ && evalF env ψ) rw [stable N φ env (lt_of_mx_lt_left h), stable N ψ env (lt_of_mx_lt_right h)] | .ball t φ, env, h => by show (match evalT? N env t with | some b => allBelow (fun x => evalF? N (cons x env) φ) (b + 1) | none => false) = allBelow (fun x => evalF (cons x env) φ) (evalT env t + 1) rw [evalT_frame N env t (lt_of_mx_lt_left h)] show allBelow (fun x => evalF? N (cons x env) φ) (evalT env t + 1) = allBelow (fun x => evalF (cons x env) φ) (evalT env t + 1) exact allBelow_congr (fun x hx => stable N φ (cons x env) (Nat.lt_of_le_of_lt (le_maxBelow (fun x => boundF (cons x env) φ) hx) (lt_of_mx_lt_right h))) /-! ### 5:C2 — records and the mirror -/ /-- The number of strings of length at most `K` over `s` letters, `Σ_{i ≤ K} s^i`. -/ def records (s : Nat) : Nat → Nat | 0 => 1 | K + 1 => records s K + s ^ (K + 1) /-- 5:C2, 29:C10 (the count) — fewer than `s^(K+1)` records exist for an alphabet of `s ≥ 2` letters. -/ theorem records_lt (s : Nat) (hs : 2 ≤ s) : ∀ K, records s K < s ^ (K + 1) | 0 => by show 1 < s ^ 1 rw [Nat.pow_succ, Nat.pow_zero, Nat.one_mul] exact Nat.lt_of_lt_of_le (Nat.lt_succ_self 1) hs | K + 1 => by show records s K + s ^ (K + 1) < s ^ (K + 1 + 1) have h1 : records s K + s ^ (K + 1) < s ^ (K + 1) + s ^ (K + 1) := Nat.add_lt_add_right (records_lt s hs K) _ have h2 : s ^ (K + 1) + s ^ (K + 1) ≤ s ^ (K + 1) * s := by rw [← Nat.mul_two]; exact Nat.mul_le_mul_left _ hs exact Nat.lt_of_lt_of_le h1 h2 /-! ### 5:C5, 5:E5 — an iteration on finitely many states repeats: periodic König and bounded halting -/ /-- `iter f x k = f^k x`. -/ def iter (f : Nat → Nat) (x : Nat) : Nat → Nat | 0 => x | k + 1 => f (iter f x k) theorem iter_lt (f : Nat → Nat) {n : Nat} (hf : ∀ y, y < n → f y < n) {x : Nat} (hx : x < n) : ∀ k, iter f x k < n | 0 => hx | k + 1 => hf _ (iter_lt f hf hx k) theorem iter_add (f : Nat → Nat) (x : Nat) (i : Nat) : ∀ k, iter f x (i + k) = iter f (iter f x i) k | 0 => rfl | k + 1 => by show f (iter f x (i + k)) = f (iter f (iter f x i) k); rw [iter_add f x i k] /-- 5:E5, 5:C5 (Lemma periodic König, the pigeonhole) — on `n` states the iteration from `x` revisits a state within `n` steps: some `i < j ≤ n` have `f^i x = f^j x`. -/ theorem repeat_below (f : Nat → Nat) (n : Nat) (hf : ∀ y, y < n → f y < n) (x : Nat) (hx : x < n) : ∃ i j, i < j ∧ j ≤ n ∧ iter f x i = iter f x j := have dec : Decidable (∃ j, j < n + 1 ∧ ∃ i, i < j ∧ iter f x i = iter f x j) := @FRC.Shell.decExistsLT (fun j => ∃ i, i < j ∧ iter f x i = iter f x j) (fun j => FRC.Shell.decExistsLT (fun i => iter f x i = iter f x j) j) (n + 1) match dec with | isTrue ⟨j, hj, i, hij, e⟩ => ⟨i, j, hij, Nat.le_of_lt_succ hj, e⟩ | isFalse hno => have hinj : ∀ i j, i < n + 1 → j < n + 1 → iter f x i = iter f x j → i = j := fun i j hi hj e => match Nat.lt_or_ge i j with | Or.inl hlt => absurd ⟨j, hj, i, hlt, e⟩ hno | Or.inr hge => match Nat.lt_or_ge j i with | Or.inl hlt => absurd ⟨i, hi, j, hlt, e.symm⟩ hno | Or.inr hge' => Nat.le_antisymm hge' hge have hnd := FRC.Shell.imageList_nodup hinj (Nat.le_refl (n + 1)) have hb : ∀ e, Pigeonhole.mem e (FRC.Shell.imageList (iter f x) (n + 1)) → e < n := fun _ he => match FRC.Shell.mem_imageList he with | ⟨k, _, ek⟩ => ek ▸ iter_lt f hf hx k have := Pigeonhole.length_le_of_nodup_lt n _ hnd hb by rw [FRC.Shell.imageList_length] at this; exact absurd this (Nat.not_succ_le_self n) theorem sub_pos {i j : Nat} (h : i < j) : 0 < j - i := match Nat.decEq (j - i) 0 with | isTrue e => have hj : j = i := by rw [← FRC.Nat.add_sub_of_le (Nat.le_of_lt h), e, Nat.add_zero] absurd (hj ▸ h) (Nat.lt_irrefl i) | isFalse e => Nat.pos_of_ne_zero e /-- 5:E5 — the walk is eventually periodic: from step `i` on, period `p = j − i` with `0 < p ≤ n`, `f^(i+k+p) x = f^(i+k) x` for every `k`. -/ theorem eventually_periodic (f : Nat → Nat) (n : Nat) (hf : ∀ y, y < n → f y < n) (x : Nat) (hx : x < n) : ∃ i p, 0 < p ∧ p ≤ n ∧ ∀ k, iter f x (i + k + p) = iter f x (i + k) := match repeat_below f n hf x hx with | ⟨i, j, hij, hjn, e⟩ => ⟨i, j - i, sub_pos hij, Nat.le_trans (Nat.sub_le j i) hjn, fun k => by rw [Nat.add_right_comm, FRC.Nat.add_sub_of_le (Nat.le_of_lt hij), iter_add f x j k, iter_add f x i k, e]⟩ /-- 5:C5 (horizon separation) — a run on `n` states reaches a state `h` iff it reaches it within `n` steps: halting for bounded space is decided from above by `n` steps of simulation. -/ theorem halts_iff_halts_below (f : Nat → Nat) (n : Nat) (hf : ∀ y, y < n → f y < n) (h : Nat) (x : Nat) (hx : x < n) : (∃ k, iter f x k = h) ↔ ∃ k, k ≤ n ∧ iter f x k = h := ⟨fun ⟨k, hk⟩ => match repeat_below f n hf x hx with | ⟨i, j, hij, hjn, e⟩ => match Nat.lt_or_ge k j with | Or.inl hkj => ⟨k, Nat.le_of_lt (Nat.lt_of_lt_of_le hkj hjn), hk⟩ | Or.inr hjk => -- the run is periodic from `i` with period `p = j − i`; reduce `k − i` modulo `p` have hp : 0 < j - i := sub_pos hij have per : ∀ q r, iter f x (i + (r + (j - i) * q)) = iter f x (i + r) := fun q r => by induction q with | zero => rw [Nat.mul_zero, Nat.add_zero] | succ q ih => rw [Nat.mul_succ, ← Nat.add_assoc r ((j - i) * q) (j - i), Nat.add_comm (r + (j - i) * q) (j - i), ← Nat.add_assoc i (j - i) (r + (j - i) * q), FRC.Nat.add_sub_of_le (Nat.le_of_lt hij), iter_add f x j, ← e, ← iter_add f x i, ih] match FRC.Nat.mod_spec (j - i) hp (k - i) with | ⟨q, hq⟩ => have hr : (k - i) % (j - i) < j - i := Nat.mod_lt _ hp have hk' : k = i + ((k - i) % (j - i) + (j - i) * q) := by rw [Nat.add_comm ((k - i) % (j - i)) _, ← hq, FRC.Nat.add_sub_of_le (Nat.le_trans (Nat.le_of_lt hij) hjk)] ⟨i + (k - i) % (j - i), Nat.le_of_lt (Nat.lt_of_lt_of_le (Nat.add_lt_add_left hr i) (by rw [FRC.Nat.add_sub_of_le (Nat.le_of_lt hij)]; exact hjn)), by rw [← per q, ← hk']; exact hk⟩, fun ⟨k, _, hk⟩ => ⟨k, hk⟩⟩ /-! ### 5:D3 — Cantor's theorem on the finite frame -/ /-- 5:D3 (Remark, the external diagonal) — Cantor's theorem holds in every finite frame: `n < 2^n`. -/ theorem cantor_finite (n : Nat) : n < 2 ^ n := Nat.lt_two_pow_self /-! ### 5:E1, 5:E2 — definable choice by the least element -/ /-- The least `x < n` with `P x`, if any: the choice function `ch(A) = min A` of Definition global-choice. -/ def leastBelow (P : Nat → Bool) : Nat → Option Nat | 0 => none | n + 1 => match leastBelow P n with | some x => some x | none => if P n then some n else none /-- 5:E1, 29:B6 — a nonempty family has a choice: if some `x < n` has `P x`, `leastBelow P n` is defined. -/ theorem leastBelow_some (P : Nat → Bool) : ∀ (n x : Nat), x < n → P x = true → ∃ y, leastBelow P n = some y | 0, x, hx, _ => absurd hx (Nat.not_lt_zero x) | n + 1, x, hx, hP => match hl : leastBelow P n with | some y => ⟨y, by show (match leastBelow P n with | some x => some x | none => if P n then some n else none) = some y rw [hl]⟩ | none => match Nat.decEq x n with | isTrue e => ⟨n, by show (match leastBelow P n with | some x => some x | none => if P n then some n else none) = some n rw [hl] show (if P n then some n else none) = some n have hPn : P n = true := e ▸ hP rw [hPn, ite_eq_left rfl]⟩ | isFalse e => absurd (leastBelow_some P n x (Nat.lt_of_le_of_ne (Nat.le_of_lt_succ hx) e) hP) (fun ⟨z, hz⟩ => nomatch (hl ▸ hz : (none : Option Nat) = some z)) /-- 5:E1, 29:B6, 29:E2 (Proposition finite-choice) — the choice is a member, below the bound, and the least one. -/ theorem leastBelow_spec (P : Nat → Bool) : ∀ (n x : Nat), leastBelow P n = some x → x < n ∧ P x = true ∧ ∀ y, y < x → P y = false | 0, x, h => nomatch (h : (none : Option Nat) = some x) | n + 1, x, h => by have h' : (match leastBelow P n with | some x => some x | none => if P n then some n else none) = some x := h clear h revert h' match hl : leastBelow P n with | some y => intro h' have e : y = x := Option.some.inj h' have := leastBelow_spec P n y hl exact ⟨Nat.lt_succ_of_lt (e ▸ this.1), e ▸ this.2.1, e ▸ this.2.2⟩ | none => intro h' have h'' : (if P n then some n else none) = some x := h' match hP : P n with | true => rw [hP, ite_eq_left rfl] at h'' have e : n = x := Option.some.inj h'' refine ⟨Nat.lt_succ_of_le (Nat.le_of_eq e.symm), e ▸ hP, fun y hy => ?_⟩ match hPy : P y with | false => rfl | true => exact absurd (leastBelow_some P n y (e.symm ▸ hy) hPy) (fun ⟨z, hz⟩ => nomatch (hl ▸ hz : (none : Option Nat) = some z)) | false => rw [hP, ite_eq_right Bool.false_ne_true] at h'' exact nomatch (h'' : (none : Option Nat) = some x) /-- 5:E2 (Lemma periodic choice) — the choice depends on the set alone: pointwise equal families choose alike, so an equality-periodic family `A_{i+N} = A_i` has a choice function of the same period. -/ theorem leastBelow_congr {P Q : Nat → Bool} : ∀ {n : Nat}, (∀ x, x < n → P x = Q x) → leastBelow P n = leastBelow Q n | 0, _ => rfl | n + 1, h => by show (match leastBelow P n with | some x => some x | none => if P n then some n else none) = (match leastBelow Q n with | some x => some x | none => if Q n then some n else none) rw [leastBelow_congr (fun x hx => h x (Nat.lt_succ_of_lt hx)), h n (Nat.lt_succ_self n)] /-! ### The counting core of 25-godel -/ theorem or_intro_left {a b : Bool} (h : a = true) : (a || b) = true := by rw [h]; rfl theorem or_intro_right {a b : Bool} (h : b = true) : (a || b) = true := by rw [h]; cases a <;> rfl theorem and_true' (c : Bool) : (c && true) = c := by cases c <;> rfl theorem and_false' (c : Bool) : (c && false) = false := by cases c <;> rfl theorem and_self' (c : Bool) : (c && c) = c := by cases c <;> rfl theorem or_false' (c : Bool) : (c || false) = c := by cases c <;> rfl theorem and_assoc' (a b c : Bool) : ((a && b) && c) = (a && (b && c)) := by cases a <;> rfl /-- 25:C1, 29:B5 (Proposition noQ, the pigeonhole) — on `[0, n)` an injective map is onto: every `z < n` is a value. -/ theorem inj_onto (n : Nat) (S : Nat → Nat) (hS : ∀ x, x < n → S x < n) (hinj : ∀ x y, x < n → y < n → S x = S y → x = y) (z : Nat) (hz : z < n) : ∃ x, x < n ∧ S x = z := have hnd := FRC.Shell.imageList_nodup hinj (Nat.le_refl n) have hlen := FRC.Shell.imageList_length S n have hb : ∀ e, Pigeonhole.mem e (FRC.Shell.imageList S n) → e < n := fun _ he => match FRC.Shell.mem_imageList he with | ⟨j, hj, ej⟩ => ej ▸ hS j hj FRC.Shell.mem_imageList (Pigeonhole.mem_of_nodup_of_length_lt n _ hnd hb hlen z hz) /-- 25:C1, 29:B4, 29:B5 (Proposition noQ) — no successor of `Q` on a finite carrier: no map of `[0, n)` into itself is injective and omits an element, so no finite structure is a model of `Q`. -/ theorem no_finite_successor (n : Nat) (S : Nat → Nat) (hS : ∀ x, x < n → S x < n) (hinj : ∀ x y, x < n → y < n → S x = S y → x = y) (z : Nat) (hz : z < n) : ¬ ∀ x, x < n → S x ≠ z := fun hmiss => match inj_onto n S hS hinj z hz with | ⟨x, hx, e⟩ => hmiss x hx e /-- 25:D1 (Theorem part) — an agent with `R` storage states in a structure of `m > R` elements has no injective encoding: every reading `ρ : [0, m) → [0, R)` identifies two elements. -/ theorem part_collides {m R : Nat} (hR : R < m) (ρ : Nat → Nat) (hρ : ∀ i, i < m → ρ i < R) : ¬ ∀ i j, i < m → j < m → ρ i = ρ j → i = j := fun hinj => no_mirror hR ρ hρ hinj /-- 25:C5 (Remark Tarski scoped, the count) — `m + 1` sentences, indexed `0, …, m` (the row's sentences `φ, ¬φ, …, ¬^m φ`), admit no injective numbering into a structure of `m` elements. -/ theorem sentences_outnumber (m : Nat) (g : Nat → Nat) (hg : ∀ i, i < m + 1 → g i < m) : ¬ ∀ i j, i < m + 1 → j < m + 1 → g i = g j → i = j := part_collides (Nat.lt_succ_self m) g hg /-- The number of `i < n` with `f i = true`. -/ def count (f : Nat → Bool) : Nat → Nat | 0 => 0 | n + 1 => count f n + cond (f n) 1 0 theorem count_full {f : Nat → Bool} : ∀ {n : Nat}, (∀ i, i < n → f i = true) → count f n = n | 0, _ => rfl | n + 1, h => by show count f n + cond (f n) 1 0 = n + 1 rw [h n (Nat.lt_succ_self n), count_full (fun i hi => h i (Nat.lt_succ_of_lt hi))]; rfl theorem cond_or_le (a b : Bool) : cond (a || b) 1 0 ≤ cond a 1 0 + cond b 1 0 := by cases a <;> cases b <;> decide theorem count_or_le (f g : Nat → Bool) : ∀ n, count (fun i => f i || g i) n ≤ count f n + count g n | 0 => Nat.le_refl 0 | n + 1 => by show count (fun i => f i || g i) n + cond (f n || g n) 1 0 ≤ (count f n + cond (f n) 1 0) + (count g n + cond (g n) 1 0) rw [FRC.Nat.add_add_add_comm (count f n) (cond (f n) 1 0) (count g n) (cond (g n) 1 0)] exact Nat.add_le_add (count_or_le f g n) (cond_or_le (f n) (g n)) theorem count_shift (f : Nat → Bool) : ∀ n, count (fun i => f (i + 1)) n ≤ count f (n + 1) | 0 => Nat.zero_le _ | n + 1 => by show count (fun i => f (i + 1)) n + cond (f (n + 1)) 1 0 ≤ count f (n + 1) + cond (f (n + 1)) 1 0 exact Nat.add_le_add_right (count_shift f n) _ theorem count_false : ∀ n, count (fun _ => false) n = 0 | 0 => rfl | n + 1 => by show count (fun _ => false) n + 0 = 0 rw [count_false n] theorem count_single (j : Nat) : ∀ n, count (fun i => decide (j = i)) n ≤ 1 ∧ (n ≤ j → count (fun i => decide (j = i)) n = 0) | 0 => ⟨Nat.zero_le 1, fun _ => rfl⟩ | n + 1 => match Nat.decEq j n with | isTrue e => by have h0 : count (fun i => decide (j = i)) n = 0 := (count_single j n).2 (e ▸ Nat.le_refl j) refine ⟨?_, fun hle => absurd (e ▸ hle : n + 1 ≤ n) (Nat.not_succ_le_self n)⟩ show count (fun i => decide (j = i)) n + cond (decide (j = n)) 1 0 ≤ 1 rw [h0, decide_eq_true e]; exact Nat.le_refl 1 | isFalse e => by refine ⟨?_, fun hle => ?_⟩ · show count (fun i => decide (j = i)) n + cond (decide (j = n)) 1 0 ≤ 1 rw [decide_eq_false e]; exact (count_single j n).1 · show count (fun i => decide (j = i)) n + cond (decide (j = n)) 1 0 = 0 rw [decide_eq_false e]; exact (count_single j n).2 (Nat.le_of_succ_le hle) theorem count_shift_by : ∀ (j : Nat) (f : Nat → Bool) (N : Nat), count (fun i => f (i + j)) N ≤ count f (N + j) | 0, _, _ => Nat.le_refl _ | j + 1, f, N => Nat.le_trans (count_shift_by j (fun k => f (k + 1)) N) (count_shift f (N + j)) /-- 25:F4 (Lemma density, the count) — an injective coding of the `a^n` strings of length `n` into `k`-tuples over `m` elements needs `a^n ≤ m^k`. -/ theorem dense_coding {a n m k : Nat} (c : Nat → Nat) (hc : ∀ i, i < a ^ n → c i < m ^ k) (hinj : ∀ i j, i < a ^ n → j < a ^ n → c i = c j → i = j) : a ^ n ≤ m ^ k := match Nat.lt_or_ge (m ^ k) (a ^ n) with | Or.inl h => absurd hinj (part_collides h c hc) | Or.inr h => h /-- A strict power step: `m < b` gives `m^(k+1) < b^(k+1)`. -/ theorem pow_lt_pow_base {m b : Nat} (h : m < b) : ∀ k : Nat, m ^ (k + 1) < b ^ (k + 1) | 0 => show m ^ 0 * m < b ^ 0 * b from Nat.mul_lt_mul_of_le_of_lt (Nat.le_refl 1) h (Nat.zero_lt_succ 0) | k + 1 => show m ^ (k + 1) * m < b ^ (k + 1) * b from Nat.mul_lt_mul_of_lt_of_lt (pow_lt_pow_base h k) h /-- 25:F4 (Lemma density, the digit form) — if `m` has at most `d` digits in base `a` (`m < a^d`), a coding of the strings of length `n` by tuples of `k+1` coordinates with `a^n ≤ m^(k+1)` has `n < d·(k+1)`: a tuple carries fewer letters than `d` times its coordinates. -/ theorem digit_bound {a n m k d : Nat} (ha : 0 < a) (hm : m < a ^ d) (h : a ^ n ≤ m ^ (k + 1)) : n < d * (k + 1) := match Nat.lt_or_ge n (d * (k + 1)) with | Or.inl hlt => hlt | Or.inr hge => have h1 : m ^ (k + 1) < (a ^ d) ^ (k + 1) := pow_lt_pow_base hm k have h2 : a ^ (d * (k + 1)) = (a ^ d) ^ (k + 1) := FRC.Nat.pow_mul a d (k + 1) have h3 : a ^ (d * (k + 1)) ≤ a ^ n := Nat.pow_le_pow_right ha hge absurd (Nat.lt_of_le_of_lt h (h2 ▸ h1)) (Nat.not_lt.mpr h3) /-- `f 0 || … || f (n − 1)`. -/ def anyBelow (f : Nat → Bool) : Nat → Bool | 0 => false | n + 1 => f n || anyBelow f n theorem anyBelow_congr {f g : Nat → Bool} : ∀ {n : Nat}, (∀ x, x < n → f x = g x) → anyBelow f n = anyBelow g n | 0, _ => rfl | n + 1, h => by show (f n || anyBelow f n) = (g n || anyBelow g n) rw [h n (Nat.lt_succ_self n), anyBelow_congr (fun x hx => h x (Nat.lt_succ_of_lt hx))] theorem anyBelow_false : ∀ n, anyBelow (fun _ => false) n = false | 0 => rfl | n + 1 => by show (false || anyBelow (fun _ => false) n) = false rw [anyBelow_false n]; rfl theorem allBelow_const (b : Bool) : ∀ n, 0 < n → allBelow (fun _ => b) n = b | 0, h => absurd h (Nat.lt_irrefl 0) | 1, _ => and_true' b | n + 2, _ => by show (b && allBelow (fun _ => b) (n + 1)) = b rw [allBelow_const b (n + 1) (Nat.succ_pos n)]; exact and_self' b theorem anyBelow_and_const (c : Bool) (F : Nat → Bool) (n : Nat) : anyBelow (fun x => c && F x) n = (c && anyBelow F n) := by cases c · exact anyBelow_false n · rfl theorem allBelow_and_const (c : Bool) (F : Nat → Bool) (n : Nat) (hn : 0 < n) : allBelow (fun y => c && F y) n = (c && allBelow F n) := by cases c · exact allBelow_const false n hn · rfl /-- Among the `x < n`, the clause `x = y` picks `y`: `∃ x < n, (c ∧ x = y ∧ F x)` is `c ∧ F y` for `y < n`. -/ theorem anyBelow_pick (c : Bool) (F : Nat → Bool) (y : Nat) : ∀ n, anyBelow (fun x => (c && decide (x = y)) && F x) n = (if y < n then c && F y else false) | 0 => rfl | n + 1 => by show (((c && decide (n = y)) && F n) || anyBelow (fun x => (c && decide (x = y)) && F x) n) = (if y < n + 1 then c && F y else false) rw [anyBelow_pick c F y n] exact match Nat.decEq n y with | isTrue e => by rw [decide_eq_true e, and_true' c, ite_eq_right (e ▸ Nat.lt_irrefl n : ¬ y < n), or_false', ite_eq_left (e ▸ Nat.lt_succ_self n : y < n + 1), e] | isFalse e => by rw [decide_eq_false e, and_false' c] show (if y < n then c && F y else false) = (if y < n + 1 then c && F y else false) exact match Nat.decLt y n with | isTrue hlt => by rw [ite_eq_left hlt, ite_eq_left (Nat.lt_succ_of_lt hlt)] | isFalse hge => by have hne : ¬ y < n + 1 := fun h => hge (Nat.lt_of_le_of_ne (Nat.le_of_lt_succ h) (fun e' => e e'.symm)) rw [ite_eq_right hge, ite_eq_right hne] /-! ### 25:C2, 25:C3, 00:Z1 — the first-order theory of a finite structure: decidable, complete, consistent -/ /-- A finite relational structure: the elements `0, …, m − 1` and decidable relations, `rel r xs` the truth of the relation symbol `r` on the arguments `xs`. A function symbol enters through its graph. -/ structure FinStr where m : Nat rel : Nat → List Nat → Bool /-- First-order formulas over a relational signature: the atoms `R_r(x_{i₁}, …)` and `x_i = x_j` (variables as de Bruijn indices), negation, conjunction and the quantifier `∀`, which binds variable `0`. -/ inductive FForm where | rel : Nat → List Nat → FForm | eq : Nat → Nat → FForm | neg : FForm → FForm | conj : FForm → FForm → FForm | all : FForm → FForm /-- Satisfaction, the standard semantics: the quantifier ranges over the structure's elements. -/ def Sat (M : FinStr) : (Nat → Nat) → FForm → Prop | env, .rel r xs => M.rel r (xs.map env) = true | env, .eq i j => env i = env j | env, .neg φ => ¬ Sat M env φ | env, .conj φ ψ => Sat M env φ ∧ Sat M env ψ | env, .all φ => ∀ x, x < M.m → Sat M (cons x env) φ /-- Exhaustive evaluation: each quantifier tries the `m` elements. -/ def fval (M : FinStr) : (Nat → Nat) → FForm → Bool | env, .rel r xs => M.rel r (xs.map env) | env, .eq i j => decide (env i = env j) | env, .neg φ => !(fval M env φ) | env, .conj φ ψ => fval M env φ && fval M env ψ | env, .all φ => allBelow (fun x => fval M (cons x env) φ) M.m theorem allBelow_iff (f : Nat → Bool) : ∀ n, allBelow f n = true ↔ ∀ x, x < n → f x = true | 0 => ⟨fun _ _ h => absurd h (Nat.not_lt_zero _), fun _ => rfl⟩ | n + 1 => by show (f n && allBelow f n) = true ↔ _ have ih := allBelow_iff f n match hf : f n with | true => exact ⟨fun h x hx => match Nat.lt_or_ge x n with | .inl hlt => ih.1 h x hlt | .inr hge => (Nat.le_antisymm (Nat.le_of_lt_succ hx) hge) ▸ hf, fun h => ih.2 (fun x hx => h x (Nat.lt_succ_of_lt hx))⟩ | false => exact ⟨fun h => Bool.noConfusion h, fun h => Bool.noConfusion (hf ▸ h n (Nat.lt_succ_self n))⟩ /-- 25:C2, Z1, 29:B4, 29:E2 — decidable by exhaustive evaluation: a formula holds in the finite structure exactly when its evaluation is `true`. -/ theorem fin_theory_decidable (M : FinStr) : ∀ (φ : FForm) (env : Nat → Nat), fval M env φ = true ↔ Sat M env φ | .rel _ _, _ => Iff.rfl | .eq i j, env => show decide (env i = env j) = true ↔ env i = env j from ⟨of_decide_eq_true, decide_eq_true⟩ | .neg φ, env => by show (!(fval M env φ)) = true ↔ ¬ Sat M env φ have ih := fin_theory_decidable M φ env match h : fval M env φ with | true => exact ⟨fun e => Bool.noConfusion e, fun hn => absurd (ih.1 h) hn⟩ | false => exact ⟨fun _ hs => Bool.noConfusion (h ▸ ih.2 hs), fun _ => rfl⟩ | .conj φ ψ, env => by show (fval M env φ && fval M env ψ) = true ↔ Sat M env φ ∧ Sat M env ψ have i1 := fin_theory_decidable M φ env have i2 := fin_theory_decidable M ψ env match h1 : fval M env φ, h2 : fval M env ψ with | true, true => exact ⟨fun _ => ⟨i1.1 h1, i2.1 h2⟩, fun _ => rfl⟩ | true, false => exact ⟨fun e => Bool.noConfusion e, fun hs => Bool.noConfusion (h2 ▸ i2.2 hs.2)⟩ | false, _ => exact ⟨fun e => Bool.noConfusion e, fun hs => Bool.noConfusion (h1 ▸ i1.2 hs.1)⟩ | .all φ, env => by show allBelow (fun x => fval M (cons x env) φ) M.m = true ↔ ∀ x, x < M.m → Sat M (cons x env) φ exact (allBelow_iff _ M.m).trans ⟨fun h x hx => (fin_theory_decidable M φ (cons x env)).1 (h x hx), fun h x hx => (fin_theory_decidable M φ (cons x env)).2 (h x hx)⟩ /-- 25:C2, Z1, 29:B4 — the theory is complete: every formula or its negation holds, decided by the evaluation, with no appeal to excluded middle. -/ theorem fin_theory_complete (M : FinStr) (φ : FForm) (env : Nat → Nat) : Sat M env φ ∨ Sat M env (.neg φ) := match h : fval M env φ with | true => .inl ((fin_theory_decidable M φ env).1 h) | false => .inr (fun hs => Bool.noConfusion (h ▸ (fin_theory_decidable M φ env).2 hs)) /-- 25:C2, 25:C3, Z1 — the theory is consistent: no formula holds together with its negation. -/ theorem fin_theory_consistent (M : FinStr) (φ : FForm) (env : Nat → Nat) : ¬ (Sat M env φ ∧ Sat M env (.neg φ)) := fun h => h.2 h.1 /-! ### 00:Z1 — no finite structure interprets Robinson's `Q` -/ /-- The successor an interpretation defines: on the domain `D`, the least `y` in `D` with `Sg x y`; the identity off it. -/ def succOf (D : Nat → Bool) (Sg : Nat → Nat → Bool) (n x : Nat) : Nat := if D x then (match leastBelow (fun y => D y && Sg x y) n with | some y => y | none => x) else x theorem band_l {a b : Bool} (h : (a && b) = true) : a = true := by cases a <;> cases b <;> first | rfl | exact h theorem band_r {a b : Bool} (h : (a && b) = true) : b = true := by cases a <;> cases b <;> first | rfl | exact h /-- 00:Z1, 25:C1 — no finite structure carries Robinson's successor: on `[0, n)`, a domain `D`, a successor relation `Sg` total on `D`, injective (Q2) and never reaching a zero `Z` of `D` (Q1) cannot exist. A `k`-dimensional interpretation is the case `n = mᵏ`, its tuples coded below `mᵏ`. -/ theorem no_finite_Q (n : Nat) (D Z : Nat → Bool) (Sg : Nat → Nat → Bool) (htot : ∀ x, x < n → D x = true → ∃ y, y < n ∧ D y = true ∧ Sg x y = true) (hinj : ∀ x x' y, x < n → x' < n → D x = true → D x' = true → Sg x y = true → Sg x' y = true → x = x') (hz : ∃ z, z < n ∧ D z = true ∧ Z z = true) (h1 : ∀ x y, x < n → y < n → D x = true → D y = true → Sg x y = true → Z y = false) : False := by have hS : ∀ x, x < n → D x = true → ∃ y, y < n ∧ D y = true ∧ Sg x y = true ∧ succOf D Sg n x = y := fun x hx hD => by obtain ⟨y, hy, hDy, hSy⟩ := htot x hx hD obtain ⟨y0, h0⟩ := leastBelow_some (fun y => D y && Sg x y) n y hy (by rw [hDy, hSy]; rfl) have sp := leastBelow_spec _ n y0 h0 refine ⟨y0, sp.1, band_l sp.2.1, band_r sp.2.1, ?_⟩ show (if D x = true then (match leastBelow (fun y => D y && Sg x y) n with | some y => y | none => x) else x) = y0 rw [ite_eq_left hD, h0] have hoff : ∀ x, D x = false → succOf D Sg n x = x := fun x hD => by show (if D x = true then _ else x) = x rw [hD, ite_eq_right Bool.false_ne_true] obtain ⟨z, hzn, hDz, hZz⟩ := hz refine no_finite_successor n (succOf D Sg n) (fun x hx => ?_) (fun x x' hx hx' e => ?_) z hzn (fun x hx e => ?_) · match hD : D x with | true => obtain ⟨y, hy, _, _, ey⟩ := hS x hx hD; rw [ey]; exact hy | false => rw [hoff x hD]; exact hx · match hD : D x, hD' : D x' with | true, true => obtain ⟨y, _, _, hSy, ey⟩ := hS x hx hD obtain ⟨y', _, _, hSy', ey'⟩ := hS x' hx' hD' rw [ey, ey'] at e exact hinj x x' y hx hx' hD hD' hSy (e ▸ hSy') | true, false => obtain ⟨y, _, hDy, _, ey⟩ := hS x hx hD rw [ey, hoff x' hD'] at e rw [e] at hDy; rw [hDy] at hD'; exact Bool.noConfusion hD' | false, true => obtain ⟨y', _, hDy', _, ey'⟩ := hS x' hx' hD' rw [ey', hoff x hD] at e rw [← e] at hDy'; rw [hDy'] at hD; exact Bool.noConfusion hD | false, false => rw [hoff x hD, hoff x' hD'] at e; exact e · match hD : D x with | true => obtain ⟨y, hy, hDy, hSy, ey⟩ := hS x hx hD rw [ey] at e have := h1 x y hx hy hD hDy hSy rw [e, hZz] at this; exact Bool.noConfusion this | false => rw [hoff x hD] at e; rw [e, hDz] at hD; exact Bool.noConfusion hD /-- 00:Z1, 25:C1 — a finite structure interprets no Robinson `Q`: for formulas `δ` (the domain, in variable `0`), `σ` (the successor's graph, `x` in variable `1` and `y` in `0`) and `ζ` (zero), the relativised successor axioms — `S` total on the domain, Q2 (`S x = S x' → x = x'`), a zero in the domain, and Q1 (`S x ≠ 0`) — never all hold. -/ theorem no_interpretation (M : FinStr) (env : Nat → Nat) (δ σ ζ : FForm) : ¬ ((∀ x, x < M.m → Sat M (cons x env) δ → ∃ y, y < M.m ∧ Sat M (cons y env) δ ∧ Sat M (cons y (cons x env)) σ) ∧ (∀ x x' y, x < M.m → x' < M.m → Sat M (cons x env) δ → Sat M (cons x' env) δ → Sat M (cons y (cons x env)) σ → Sat M (cons y (cons x' env)) σ → x = x') ∧ (∃ z, z < M.m ∧ Sat M (cons z env) δ ∧ Sat M (cons z env) ζ) ∧ (∀ x y, x < M.m → y < M.m → Sat M (cons x env) δ → Sat M (cons y env) δ → Sat M (cons y (cons x env)) σ → ¬ Sat M (cons y env) ζ)) := fun ⟨htot, hinj, ⟨z, hz, hDz, hZz⟩, h1⟩ => by have dec := fin_theory_decidable M refine no_finite_Q M.m (fun x => fval M (cons x env) δ) (fun x => fval M (cons x env) ζ) (fun x y => fval M (cons y (cons x env)) σ) (fun x hx hD => ?_) (fun x x' y hx hx' hD hD' hS hS' => ?_) ⟨z, hz, (dec δ _).2 hDz, (dec ζ _).2 hZz⟩ (fun x y hx hy hD hDy hS => ?_) · obtain ⟨y, hy, hDy, hSy⟩ := htot x hx ((dec δ _).1 hD) exact ⟨y, hy, (dec δ _).2 hDy, (dec σ _).2 hSy⟩ · exact hinj x x' y hx hx' ((dec δ _).1 hD) ((dec δ _).1 hD') ((dec σ _).1 hS) ((dec σ _).1 hS') · match hZ : fval M (cons y env) ζ with | false => rfl | true => exact absurd ((dec ζ _).1 hZ) (h1 x y hx hy ((dec δ _).1 hD) ((dec δ _).1 hDy) ((dec σ _).1 hS)) end FRC.Logic /-! inlined: FrcCore/Theme/SecondOrder.lean -/ /-! # The full second-order theory of a finite structure (the logic theme; 29-finitism, 9 October 2026) A finite relational structure `FinStr` (`Theme/Logic.lean`) has finitely many subsets and finitely many relations of each arity. A subset of its `m` elements is coded by a number below `2^m` (bit `x` for element `x`), and a relation of arity `a` by a number below `2^(m^a)` (one bit per tuple, the tuple coded in base `m`). Second-order formulas add set and relation variables, their atoms and their quantifiers to the first-order formulas; satisfaction ranges over the codes, and exhaustive evaluation tries them all. `so_theory_decidable` is the second-order form of `fin_theory_decidable`: the full second-order theory of a finite structure is decided by evaluation (29-finitism, Corollary determinacy, the finite direction; 5-reductio D8). No axioms. -/ namespace FRC.Logic /-- Bit `x` of the code `n`: whether element `x` belongs to the subset coded by `n`. -/ def memBit (n x : Nat) : Bool := decide (n / 2 ^ x % 2 = 1) /-- The code of a tuple of elements in base `m`: `x₀ + m x₁ + m² x₂ + …`. -/ def tupleIndex (m : Nat) : List Nat → Nat | [] => 0 | x :: xs => x + m * tupleIndex m xs /-- Second-order formulas: the first-order atoms, the set atom `X_k(x_i)`, the relation atom `R_k(x_{i₁}, …)`, negation, conjunction, and the three quantifiers — over elements, over subsets (binding set variable `0`), over relations of arity `a` (binding relation variable `0`). Variables are de Bruijn indices in three sorts. -/ inductive SForm where | rel : Nat → List Nat → SForm | eq : Nat → Nat → SForm | setMem : Nat → Nat → SForm | relApp : Nat → List Nat → SForm | neg : SForm → SForm | conj : SForm → SForm → SForm | all : SForm → SForm | allSet : SForm → SForm | allRel : Nat → SForm → SForm /-- Satisfaction: the element quantifier ranges over the `m` elements, the set quantifier over the `2^m` codes of subsets, the relation quantifier of arity `a` over the `2^(m^a)` codes of relations. -/ def Sat2 (M : FinStr) : (Nat → Nat) → (Nat → Nat) → (Nat → Nat) → SForm → Prop | env, _, _, .rel r xs => M.rel r (xs.map env) = true | env, _, _, .eq i j => env i = env j | env, senv, _, .setMem k i => memBit (senv k) (env i) = true | env, _, renv, .relApp k xs => memBit (renv k) (tupleIndex M.m (xs.map env)) = true | env, senv, renv, .neg φ => ¬ Sat2 M env senv renv φ | env, senv, renv, .conj φ ψ => Sat2 M env senv renv φ ∧ Sat2 M env senv renv ψ | env, senv, renv, .all φ => ∀ x, x < M.m → Sat2 M (cons x env) senv renv φ | env, senv, renv, .allSet φ => ∀ S, S < 2 ^ M.m → Sat2 M env (cons S senv) renv φ | env, senv, renv, .allRel a φ => ∀ R, R < 2 ^ (M.m ^ a) → Sat2 M env senv (cons R renv) φ /-- Exhaustive evaluation: each quantifier tries every code below its bound. -/ def sval2 (M : FinStr) : (Nat → Nat) → (Nat → Nat) → (Nat → Nat) → SForm → Bool | env, _, _, .rel r xs => M.rel r (xs.map env) | env, _, _, .eq i j => decide (env i = env j) | env, senv, _, .setMem k i => memBit (senv k) (env i) | env, _, renv, .relApp k xs => memBit (renv k) (tupleIndex M.m (xs.map env)) | env, senv, renv, .neg φ => !(sval2 M env senv renv φ) | env, senv, renv, .conj φ ψ => sval2 M env senv renv φ && sval2 M env senv renv ψ | env, senv, renv, .all φ => allBelow (fun x => sval2 M (cons x env) senv renv φ) M.m | env, senv, renv, .allSet φ => allBelow (fun S => sval2 M env (cons S senv) renv φ) (2 ^ M.m) | env, senv, renv, .allRel a φ => allBelow (fun R => sval2 M env senv (cons R renv) φ) (2 ^ (M.m ^ a)) /-- 29:E4 — Corollary determinacy, the finite direction (5:D8): the full second-order theory of a finite structure is decided by exhaustive evaluation, a formula holds exactly when its evaluation is `true`. -/ theorem so_theory_decidable (M : FinStr) : ∀ (φ : SForm) (env senv renv : Nat → Nat), sval2 M env senv renv φ = true ↔ Sat2 M env senv renv φ | .rel _ _, _, _, _ => Iff.rfl | .eq i j, env, _, _ => show decide (env i = env j) = true ↔ env i = env j from ⟨of_decide_eq_true, decide_eq_true⟩ | .setMem _ _, _, _, _ => Iff.rfl | .relApp _ _, _, _, _ => Iff.rfl | .neg φ, env, senv, renv => by show (!(sval2 M env senv renv φ)) = true ↔ ¬ Sat2 M env senv renv φ have ih := so_theory_decidable M φ env senv renv match h : sval2 M env senv renv φ with | true => exact ⟨fun e => Bool.noConfusion e, fun hn => absurd (ih.1 h) hn⟩ | false => exact ⟨fun _ hs => Bool.noConfusion (h ▸ ih.2 hs), fun _ => rfl⟩ | .conj φ ψ, env, senv, renv => by show (sval2 M env senv renv φ && sval2 M env senv renv ψ) = true ↔ Sat2 M env senv renv φ ∧ Sat2 M env senv renv ψ have i1 := so_theory_decidable M φ env senv renv have i2 := so_theory_decidable M ψ env senv renv match h1 : sval2 M env senv renv φ, h2 : sval2 M env senv renv ψ with | true, true => exact ⟨fun _ => ⟨i1.1 h1, i2.1 h2⟩, fun _ => rfl⟩ | true, false => exact ⟨fun e => Bool.noConfusion e, fun hs => Bool.noConfusion (h2 ▸ i2.2 hs.2)⟩ | false, _ => exact ⟨fun e => Bool.noConfusion e, fun hs => Bool.noConfusion (h1 ▸ i1.2 hs.1)⟩ | .all φ, env, senv, renv => by show allBelow (fun x => sval2 M (cons x env) senv renv φ) M.m = true ↔ ∀ x, x < M.m → Sat2 M (cons x env) senv renv φ exact (allBelow_iff _ M.m).trans ⟨fun h x hx => (so_theory_decidable M φ (cons x env) senv renv).1 (h x hx), fun h x hx => (so_theory_decidable M φ (cons x env) senv renv).2 (h x hx)⟩ | .allSet φ, env, senv, renv => by show allBelow (fun S => sval2 M env (cons S senv) renv φ) (2 ^ M.m) = true ↔ ∀ S, S < 2 ^ M.m → Sat2 M env (cons S senv) renv φ exact (allBelow_iff _ (2 ^ M.m)).trans ⟨fun h S hS => (so_theory_decidable M φ env (cons S senv) renv).1 (h S hS), fun h S hS => (so_theory_decidable M φ env (cons S senv) renv).2 (h S hS)⟩ | .allRel a φ, env, senv, renv => by show allBelow (fun R => sval2 M env senv (cons R renv) φ) (2 ^ (M.m ^ a)) = true ↔ ∀ R, R < 2 ^ (M.m ^ a) → Sat2 M env senv (cons R renv) φ exact (allBelow_iff _ (2 ^ (M.m ^ a))).trans ⟨fun h R hR => (so_theory_decidable M φ env senv (cons R renv)).1 (h R hR), fun h R hR => (so_theory_decidable M φ env senv (cons R renv)).2 (h R hR)⟩ /-- 29:E4 — Corollary determinacy, the finite direction: the full second-order theory is complete, every formula or its negation holds, decided by the evaluation. -/ theorem so_theory_complete (M : FinStr) (φ : SForm) (env senv renv : Nat → Nat) : Sat2 M env senv renv φ ∨ Sat2 M env senv renv (.neg φ) := match h : sval2 M env senv renv φ with | true => .inl ((so_theory_decidable M φ env senv renv).1 h) | false => .inr (fun hs => Bool.noConfusion (h ▸ (so_theory_decidable M φ env senv renv).2 hs)) /-- 29:E4 — the full second-order theory is consistent: no formula holds together with its negation. -/ theorem so_theory_consistent (M : FinStr) (φ : SForm) (env senv renv : Nat → Nat) : ¬ (Sat2 M env senv renv φ ∧ Sat2 M env senv renv (.neg φ)) := fun h => h.2 h.1 /-- The subsets of `m` elements are `2^m` codes and the relations of arity `a` are `2^(m^a)`: both finite, and every code below the bound is a subset or a relation (every bit pattern is one). The quantifiers of `Sat2` range over exactly these, so the evaluation is uniform in the structure: `sval2` is a terminating computation on `M` presented as data. -/ theorem so_evaluation_terminates (M : FinStr) (φ : SForm) (env senv renv : Nat → Nat) : sval2 M env senv renv φ = true ∨ sval2 M env senv renv φ = false := match sval2 M env senv renv φ with | true => .inl rfl | false => .inr rfl end FRC.Logic /-! inlined: FrcCore/Theme/Formation.lean -/ /-! # Formation universes, traces and bounded certificates (prototype for 29-finitism, 9 October 2026) The objects of `29-finitism` (The Undeclared Posit of Potential Infinity) in the core's grammar: a universe of formations is a finite set of objects `0, …, size − 1` with a formation image `form x`, `none` where formation fails; a trace is what a completed check reads — `t` mentioned objects and the formation atoms it asserts among them; a check passes in a universe under a reading of its objects. No imports beyond the logic theme; no axioms. -/ namespace FRC.Formation /-- A universe of formations: `size` objects and the formation image `form x` of each (`none`: the act fails at `x`). -/ structure Universe where size : Nat form : Nat → Option Nat /-- Closed: every formation image is an object of the universe. -/ def Universe.Closed (U : Universe) : Prop := ∀ x y, x < U.size → U.form x = some y → y < U.size /-- The trace of a completed check: `t` mentioned objects `0, …, t − 1` and the formation atoms it asserts, `atom i j = true` reading "the formation image of `i` is `j`". -/ structure Trace where t : Nat atom : Nat → Nat → Bool /-- The check passes in `U` under the reading `e`: the mentioned objects are distinct objects of `U` and every asserted formation holds there. The check reads nothing else (the locality clause of Definition agent). -/ def Passes (T : Trace) (U : Universe) (e : Nat → Nat) : Prop := (∀ i, i < T.t → e i < U.size) ∧ (∀ i j, i < T.t → j < T.t → e i = e j → i = j) ∧ (∀ i j, i < T.t → j < T.t → T.atom i j = true → U.form (e i) = some (e j)) /-! ### Theorem idleness — every passed check passes in a finite universe of its trace's size -/ /-- The minimal realization: exactly the trace's objects, each formed to the least object the trace asserts for it. -/ def minimal (T : Trace) : Universe := ⟨T.t, fun i => Logic.leastBelow (fun j => T.atom i j) T.t⟩ /-- 29:C2, 29:C7 — the minimal realization has exactly the trace's `t` objects. -/ theorem minimal_size (T : Trace) : (minimal T).size = T.t := rfl /-- A passed check asserts at most one image per object: the atoms are functional on the trace. -/ theorem atoms_functional (T : Trace) (U : Universe) (e : Nat → Nat) (h : Passes T U e) : ∀ i j j', i < T.t → j < T.t → j' < T.t → T.atom i j = true → T.atom i j' = true → j = j' := fun i j j' hi hj hj' ha ha' => have e1 := h.2.2 i j hi hj ha have e2 := h.2.2 i j' hi hj' ha' h.2.1 j j' hj hj' (Option.some.inj (e1.symm.trans e2)) /-- 29:C2 — Theorem idleness (the core form): a check that passes anywhere passes in the finite universe of its own trace, read by the identity: `t(r)` objects suffice. -/ theorem realized (T : Trace) (U : Universe) (e : Nat → Nat) (h : Passes T U e) : Passes T (minimal T) (fun i => i) := by refine ⟨fun i hi => hi, fun i j _ _ hij => hij, fun i j hi hj ha => ?_⟩ show Logic.leastBelow (fun k => T.atom i k) T.t = some j obtain ⟨y, hy⟩ := Logic.leastBelow_some (fun k => T.atom i k) T.t j hj ha have sp := Logic.leastBelow_spec (fun k => T.atom i k) T.t y hy rw [hy, atoms_functional T U e h i y j hi sp.1 hj sp.2.1 ha] /-- 29:C2 — the minimal realization is closed: every image it assigns is one of its objects. -/ theorem minimal_closed (T : Trace) : (minimal T).Closed := fun x y _ hxy => (Logic.leastBelow_spec (fun k => T.atom x k) T.t y hxy).1 /-! ### Corollary symmetry (the bound clause) — padding: the check passes in universes of every larger size -/ /-- `U` with `k` fresh objects appended, formation failing at each. -/ def pad (U : Universe) (k : Nat) : Universe := ⟨U.size + k, fun x => if x < U.size then U.form x else none⟩ theorem pad_size (U : Universe) (k : Nat) : (pad U k).size = U.size + k := rfl theorem pad_form (U : Universe) (k x : Nat) (hx : x < U.size) : (pad U k).form x = U.form x := by show (if x < U.size then U.form x else none) = U.form x rw [ite_eq_left hx] /-- 29:C4 — Corollary symmetry, the bound: a passed check passes unchanged after padding by any number of formations, so for every `B` there is a realizing universe of more than `B` objects and the passing entails no bound. -/ theorem passes_pad (T : Trace) (U : Universe) (e : Nat → Nat) (h : Passes T U e) (k : Nat) : Passes T (pad U k) e := by refine ⟨fun i hi => Nat.lt_of_lt_of_le (h.1 i hi) (Nat.le_add_right _ _), h.2.1, fun i j hi hj ha => ?_⟩ rw [pad_form U k (e i) (h.1 i hi)]; exact h.2.2 i j hi hj ha /-- 29:C4 — the realization at every size: for every `k` the minimal realization padded by `k` fresh formations has exactly `t + k` objects, is closed, and the check passes in it read by the identity. No size is entailed. -/ theorem realization_at_size (T : Trace) (U : Universe) (e : Nat → Nat) (h : Passes T U e) (k : Nat) : Passes T (pad (minimal T) k) (fun i => i) ∧ (pad (minimal T) k).size = T.t + k ∧ (pad (minimal T) k).Closed := ⟨passes_pad T (minimal T) _ (realized T U e h) k, rfl, fun x y hx hxy => by have hxy' : (if x < T.t then (minimal T).form x else none) = some y := hxy match Nat.lt_or_ge x T.t with | .inl hlt => rw [ite_eq_left hlt] at hxy' exact Nat.lt_of_lt_of_le (minimal_closed T x y hlt hxy') (Nat.le_add_right _ _) | .inr hge => rw [ite_eq_right (Nat.not_lt.2 hge)] at hxy' cases hxy'⟩ /-! ### The cyclic exhibit of Proposition posits — the successor act on the cycle of `n` points -/ /-- The successor on the cycle of `n` points: `x ↦ x + 1 (mod n)`. -/ def cyc (n x : Nat) : Nat := (x + 1) % n /-- 29:B4 — the act is total: it stays on the cycle. -/ theorem cyc_lt (n : Nat) (hn : 0 < n) (x : Nat) : cyc n x < n := FRC.Nat.mod_lt' _ hn theorem cyc_iter (n : Nat) (hn : 0 < n) (x : Nat) (hx : x < n) : ∀ k, Logic.iter (cyc n) x k = (x + k) % n | 0 => (FRC.Nat.mod_eq_of_lt hx).symm | k + 1 => by show cyc n (Logic.iter (cyc n) x k) = (x + (k + 1)) % n rw [cyc_iter n hn x hx k] show ((x + k) % n + 1) % n = (x + (k + 1)) % n rw [FRC.Nat.mod_add_mod _ _ _ hn, Nat.add_assoc] /-- 29:B4 — the act returns to its start after `n` steps: the orbit is a cycle, so iteration makes nothing new. -/ theorem cyc_return (n : Nat) (hn : 0 < n) (x : Nat) (hx : x < n) : Logic.iter (cyc n) x n = x := by rw [cyc_iter n hn x hx n, Nat.add_comm] have : (n + x) % n = (n * 1 + x) % n := by rw [Nat.mul_one] rw [this, FRC.Nat.add_mul_mod_self_left x 1 n hn, FRC.Nat.mod_eq_of_lt hx] /-- The act is injective on the cycle. -/ theorem cyc_inj (n : Nat) (hn : 0 < n) : ∀ x y, x < n → y < n → cyc n x = cyc n y → x = y := fun x y hx hy e => by have key : ∀ z, z < n → cyc n z = if z + 1 < n then z + 1 else 0 := fun z hz => by show (z + 1) % n = _ by_cases h : z + 1 < n · rw [ite_eq_left h]; exact FRC.Nat.mod_eq_of_lt h · rw [ite_eq_right h] have : z + 1 = n := Nat.le_antisymm (Nat.succ_le_of_lt hz) (Nat.le_of_not_lt h) rw [this]; exact FRC.Nat.mod_self n hn rw [key x hx, key y hy] at e by_cases h1 : x + 1 < n <;> by_cases h2 : y + 1 < n · rw [ite_eq_left h1, ite_eq_left h2] at e; exact Nat.succ.inj e · rw [ite_eq_left h1, ite_eq_right h2] at e; exact absurd e (Nat.succ_ne_zero x) · rw [ite_eq_right h1, ite_eq_left h2] at e; exact absurd e.symm (Nat.succ_ne_zero y) · have ex : x + 1 = n := Nat.le_antisymm (Nat.succ_le_of_lt hx) (Nat.le_of_not_lt h1) have ey : y + 1 = n := Nat.le_antisymm (Nat.succ_le_of_lt hy) (Nat.le_of_not_lt h2) exact Nat.succ.inj (ex.trans ey.symm) /-- 29:B4 — every point of the cycle is already an image: the act produces no new formation (the pigeonhole, `inj_onto`). -/ theorem cyc_onto (n : Nat) (hn : 0 < n) (z : Nat) (hz : z < n) : ∃ x, x < n ∧ cyc n x = z := Logic.inj_onto n (cyc n) (fun x _ => cyc_lt n hn x) (cyc_inj n hn) z hz /-! ### Lemma boundary, Case 1 — the disjoint double, its swap, and the parity of invariant conditions -/ /-- The disjoint double `U ⊔ U`: the objects `x < n` the first copy, `n + x` the second, each formed inside its copy. -/ def double (U : Universe) : Universe := ⟨U.size + U.size, fun x => if x < U.size then U.form x else match U.form (x - U.size) with | some y => some (U.size + y) | none => none⟩ /-- The swap of the two copies. -/ def swap (U : Universe) (x : Nat) : Nat := if x < U.size then U.size + x else x - U.size theorem swap_lt (U : Universe) (x : Nat) (hx : x < (double U).size) : swap U x < (double U).size := by show (if x < U.size then U.size + x else x - U.size) < U.size + U.size by_cases h : x < U.size · rw [ite_eq_left h]; exact Nat.add_lt_add_left h _ · rw [ite_eq_right h] exact Nat.lt_of_lt_of_le (FRC.Nat.sub_lt_of_lt_add hx (Nat.le_of_not_lt h)) (Nat.le_add_left _ _) /-- 29:C6 — the swap is an involution. -/ theorem swap_swap (U : Universe) (x : Nat) (hx : x < (double U).size) : swap U (swap U x) = x := by show (if (if x < U.size then U.size + x else x - U.size) < U.size then U.size + (if x < U.size then U.size + x else x - U.size) else (if x < U.size then U.size + x else x - U.size) - U.size) = x by_cases h : x < U.size · rw [ite_eq_left h] have : ¬ U.size + x < U.size := Nat.not_lt.2 (Nat.le_add_right _ _) rw [ite_eq_right this, FRC.Nat.add_sub_cancel_left] · rw [ite_eq_right h] have hlt : x - U.size < U.size := FRC.Nat.sub_lt_of_lt_add hx (Nat.le_of_not_lt h) rw [ite_eq_left hlt, FRC.Nat.add_sub_of_le (Nat.le_of_not_lt h)] /-- 29:C6 — the swap moves every object: no fixed point. -/ theorem swap_ne (U : Universe) (x : Nat) (hx : x < (double U).size) : swap U x ≠ x := by show (if x < U.size then U.size + x else x - U.size) ≠ x by_cases h : x < U.size · rw [ite_eq_left h]; intro e have : U.size + x = 0 + x := by rw [Nat.zero_add]; exact e exact Nat.lt_irrefl 0 (Nat.lt_of_lt_of_le (Nat.lt_of_le_of_lt (Nat.zero_le _) h) (Nat.le_of_eq (FRC.Nat.add_right_cancel this))) · rw [ite_eq_right h]; intro e have hx2 : x < U.size + U.size := hx have hpos : 0 < U.size := match hU0 : U.size, hx2 with | 0, hx0 => absurd hx0 (Nat.not_lt_zero x) | m + 1, _ => Nat.succ_pos m have : x - U.size < x := Nat.sub_lt (Nat.lt_of_lt_of_le hpos (Nat.le_of_not_lt h)) hpos rw [e] at this; exact Nat.lt_irrefl x this theorem double_form_left (U : Universe) (x : Nat) (hx : x < U.size) : (double U).form x = U.form x := by show (if x < U.size then U.form x else _) = U.form x rw [ite_eq_left hx] theorem double_form_right (U : Universe) (x : Nat) (_hx : x < U.size) : (double U).form (U.size + x) = match U.form x with | some y => some (U.size + y) | none => none := by show (if U.size + x < U.size then _ else match U.form (U.size + x - U.size) with | some y => some (U.size + y) | none => none) = _ have : ¬ U.size + x < U.size := Nat.not_lt.2 (Nat.le_add_right _ _) rw [ite_eq_right this, FRC.Nat.add_sub_cancel_left] theorem double_form_right' (U : Universe) (x : Nat) (h : ¬ x < U.size) : (double U).form x = match U.form (x - U.size) with | some y => some (U.size + y) | none => none := by show (if x < U.size then _ else match U.form (x - U.size) with | some y => some (U.size + y) | none => none) = _ rw [ite_eq_right h] /-- 29:C6 — the swap is an automorphism of the double: it commutes with formation. -/ theorem swap_form (U : Universe) (hU : U.Closed) (x : Nat) (hx : x < (double U).size) : (double U).form (swap U x) = match (double U).form x with | some y => some (swap U y) | none => none := by by_cases h : x < U.size · have hs : swap U x = U.size + x := by show (if x < U.size then _ else _) = _; rw [ite_eq_left h] rw [hs, double_form_right U x h, double_form_left U x h] match hf : U.form x with | none => rfl | some y => have hy : y < U.size := hU x y h hf show some (U.size + y) = some (if y < U.size then U.size + y else y - U.size) rw [ite_eq_left hy] · have hxs : x - U.size < U.size := FRC.Nat.sub_lt_of_lt_add hx (Nat.le_of_not_lt h) have hs : swap U x = x - U.size := by show (if x < U.size then _ else _) = _; rw [ite_eq_right h] rw [hs, double_form_left U _ hxs, double_form_right' U x h] match hf : U.form (x - U.size) with | none => rfl | some y => show some y = some (if U.size + y < U.size then _ else U.size + y - U.size) have : ¬ U.size + y < U.size := Nat.not_lt.2 (Nat.le_add_right _ _) rw [ite_eq_right this, FRC.Nat.add_sub_cancel_left] /-- 29:C6 — a passed check passes in the double, read in the first copy. -/ theorem passes_double (T : Trace) (U : Universe) (e : Nat → Nat) (h : Passes T U e) : Passes T (double U) e := by refine ⟨fun i hi => Nat.lt_of_lt_of_le (h.1 i hi) (Nat.le_add_right _ _), h.2.1, fun i j hi hj ha => ?_⟩ rw [double_form_left U (e i) (h.1 i hi)]; exact h.2.2 i j hi hj ha /-- Counting over two blocks. -/ theorem count_add (f : Nat → Bool) (a : Nat) : ∀ b, Logic.count f (a + b) = Logic.count f a + Logic.count (fun i => f (a + i)) b | 0 => rfl | b + 1 => by show Logic.count f (a + b) + cond (f (a + b)) 1 0 = Logic.count f a + (Logic.count (fun i => f (a + i)) b + cond (f (a + b)) 1 0) rw [count_add f a b, Nat.add_assoc] theorem count_congr {f g : Nat → Bool} : ∀ {n : Nat}, (∀ i, i < n → f i = g i) → Logic.count f n = Logic.count g n | 0, _ => rfl | n + 1, h => by show Logic.count f n + cond (f n) 1 0 = Logic.count g n + cond (g n) 1 0 rw [count_congr (fun i hi => h i (Nat.lt_succ_of_lt hi)), h n (Nat.lt_succ_self n)] /-- 29:C6 — Lemma boundary, Case 1: a condition invariant under the swap has an even number of satisfiers in the double, its satisfiers come in pairs. -/ theorem invariant_count_even (U : Universe) (D : Nat → Bool) (hD : ∀ x, x < (double U).size → D (swap U x) = D x) : Logic.count D (double U).size = 2 * Logic.count D U.size := by show Logic.count D (U.size + U.size) = 2 * Logic.count D U.size rw [count_add D U.size U.size, Nat.two_mul] have : ∀ i, i < U.size → D (U.size + i) = D i := fun i hi => by have hs : swap U i = U.size + i := by show (if i < U.size then _ else _) = _; rw [ite_eq_left hi] rw [← hs]; exact hD i (Nat.lt_of_lt_of_le hi (Nat.le_add_right _ _)) rw [count_congr this] /-- 29:C6, 29:X1 — a swap-invariant condition has zero or at least two satisfiers, never exactly one. -/ theorem no_unique_invariant (U : Universe) (D : Nat → Bool) (hD : ∀ x, x < (double U).size → D (swap U x) = D x) : Logic.count D (double U).size ≠ 1 := by rw [invariant_count_even U D hD] intro h cases hc : Logic.count D U.size with | zero => rw [hc] at h; exact Nat.noConfusion h | succ c => rw [hc, Nat.mul_succ] at h; exact Nat.noConfusion (Nat.succ.inj h) /-! ### Lemma boundary, Case 2 — the minimal realization confines satisfiers to the trace -/ /-- 29:C7, 29:X1 — Lemma boundary, Case 2: in the minimal realization a datum the trace never forms has no preimage, so the backward condition "the object whose formation image is `x`" has zero satisfiers. -/ theorem no_preimage_in_minimal (T : Trace) (x : Nat) (hx : ∀ i, i < T.t → T.atom i x = false) : ∀ y, y < T.t → (minimal T).form y ≠ some x := fun y hy e => have sp := Logic.leastBelow_spec (fun k => T.atom y k) T.t x e Bool.noConfusion ((hx y hy).symm.trans sp.2.1) /-! ### Lemma innocence (ii) — induction is a theorem of every finite frame -/ /-- 29:B6, 29:E2, 29:X2 — Lemma innocence (ii): on the finite frame `[0, n)` the induction schema holds for every property, from the least-number principle (`leastBelow`): a property true at `0` and closed under successor below `n` holds below `n`. -/ theorem finite_induction (n : Nat) (P : Nat → Bool) (h0 : P 0 = true) (hs : ∀ x, x + 1 < n → P x = true → P (x + 1) = true) : ∀ x, x < n → P x = true := fun x hx => by match hP : P x with | true => rfl | false => exfalso obtain ⟨m, hm⟩ := Logic.leastBelow_some (fun y => !P y) n x hx (by rw [hP]; rfl) have sp := Logic.leastBelow_spec (fun y => !P y) n m hm cases m with | zero => have := sp.2.1; rw [h0] at this; exact Bool.noConfusion this | succ k => have hk : P k = true := by have := sp.2.2 k (Nat.lt_succ_self k) match hPk : P k with | true => rfl | false => rw [hPk] at this; exact Bool.noConfusion this have := sp.2.1; rw [hs k sp.1 hk] at this; exact Bool.noConfusion this /-! ### Proposition illusion — the buffer frame -/ /-- The buffer frame: `σ` seeds, each the root of a chain of `D` formations; object `s (D + 1) + k` is seed `s` at level `k ≤ D`; formation steps up the chain and fails at the top. -/ def buffer (σ D : Nat) : Universe := ⟨σ * (D + 1), fun x => if x % (D + 1) < D ∧ x < σ * (D + 1) then some (x + 1) else none⟩ theorem buffer_size (σ D : Nat) : (buffer σ D).size = σ * (D + 1) := rfl /-- 29:C8 — every object below the top level has a formation image: the act succeeds at every level `k < D`. -/ theorem buffer_forms (σ D x : Nat) (hx : x < σ * (D + 1)) (hk : x % (D + 1) < D) : (buffer σ D).form x = some (x + 1) := by show (if x % (D + 1) < D ∧ x < σ * (D + 1) then some (x + 1) else none) = some (x + 1) rw [ite_eq_left ⟨hk, hx⟩] /-- 29:C8 — the image is fresh: one level up, inside the frame. -/ theorem buffer_fresh (σ D x : Nat) (hx : x < σ * (D + 1)) (hk : x % (D + 1) < D) : x + 1 < σ * (D + 1) ∧ (x + 1) % (D + 1) = x % (D + 1) + 1 := by have hD : 0 < D + 1 := Nat.succ_pos D obtain ⟨q, hq⟩ := FRC.Nat.mod_spec (D + 1) hD x have hr : x % (D + 1) + 1 < D + 1 := Nat.add_lt_add_right hk 1 have e : x + 1 = (D + 1) * q + (x % (D + 1) + 1) := by rw [← Nat.add_assoc, ← hq] refine ⟨?_, FRC.Nat.mod_unique hr e⟩ -- x + 1 < σ(D+1): x lies in block q, x + 1 stays in block q since its residue is below D + 1 have hq' : q < σ := match Nat.lt_or_ge q σ with | .inl hlt => hlt | .inr hσ => have h1 : σ * (D + 1) ≤ (D + 1) * q := by rw [Nat.mul_comm]; exact Nat.mul_le_mul_left _ hσ have h2 : (D + 1) * q ≤ x := by rw [hq]; exact Nat.le_add_right _ _ absurd (Nat.lt_of_lt_of_le hx (Nat.le_trans h1 h2)) (Nat.lt_irrefl x) rw [e] calc (D + 1) * q + (x % (D + 1) + 1) < (D + 1) * q + (D + 1) := Nat.add_lt_add_left hr _ _ = (D + 1) * (q + 1) := by rw [Nat.mul_succ] _ ≤ (D + 1) * σ := Nat.mul_le_mul_left _ hq' _ = σ * (D + 1) := Nat.mul_comm _ _ /-- The levels reached by iterating formation from a seed: `k` acts from seed `s` reach level `k`, for `k ≤ D`. -/ def chain (σ D s : Nat) : Nat → Option Nat | 0 => some (s * (D + 1)) | k + 1 => match chain σ D s k with | some x => (buffer σ D).form x | none => none /-- 29:C8 — `k` acts from seed `s` reach level `k`, for `k ≤ D`. -/ theorem chain_level (σ D s : Nat) (hs : s < σ) : ∀ k, k ≤ D → chain σ D s k = some (s * (D + 1) + k) | 0, _ => rfl | k + 1, hk => by show (match chain σ D s k with | some x => (buffer σ D).form x | none => none) = some (s * (D + 1) + (k + 1)) rw [chain_level σ D s hs k (Nat.le_of_succ_le hk)] have hD : 0 < D + 1 := Nat.succ_pos D have hmod : (s * (D + 1) + k) % (D + 1) = k := FRC.Nat.mod_unique (Nat.lt_of_lt_of_le (Nat.lt_succ_of_le (Nat.le_of_succ_le hk)) (Nat.le_refl _)) (by rw [Nat.mul_comm]) have hlt : s * (D + 1) + k < σ * (D + 1) := calc s * (D + 1) + k < s * (D + 1) + (D + 1) := Nat.add_lt_add_left (Nat.lt_succ_of_le (Nat.le_of_succ_le hk)) _ _ = (s + 1) * (D + 1) := by rw [Nat.succ_mul] _ ≤ σ * (D + 1) := Nat.mul_le_mul_right _ hs show (buffer σ D).form (s * (D + 1) + k) = some (s * (D + 1) + (k + 1)) rw [buffer_forms σ D _ hlt (by rw [hmod]; exact Nat.lt_of_succ_le hk)] rfl /-- 29:C8, 29:X1 — Proposition illusion (i), (ii) in the core: in the buffer frame of `σ` seeds and `D` rounds, every object reached by fewer than `D` acts from a seed has a formation image, and the image is one level further: no act on a reachable object fails and no enumeration below the horizon `D` is exhausted. -/ theorem illusion (σ D s k : Nat) (hs : s < σ) (hk : k < D) : ∃ x y, chain σ D s k = some x ∧ (buffer σ D).form x = some y ∧ chain σ D s (k + 1) = some y ∧ x < y ∧ y < (buffer σ D).size := by have hx := chain_level σ D s hs k (Nat.le_of_lt hk) have hy := chain_level σ D s hs (k + 1) hk refine ⟨s * (D + 1) + k, s * (D + 1) + (k + 1), hx, ?_, hy, Nat.lt_succ_self _, ?_⟩ · have hmod : (s * (D + 1) + k) % (D + 1) = k := FRC.Nat.mod_unique (Nat.lt_succ_of_lt hk) (by rw [Nat.mul_comm]) have hlt : s * (D + 1) + k < σ * (D + 1) := calc s * (D + 1) + k < s * (D + 1) + (D + 1) := Nat.add_lt_add_left (Nat.lt_succ_of_lt hk) _ _ = (s + 1) * (D + 1) := by rw [Nat.succ_mul] _ ≤ σ * (D + 1) := Nat.mul_le_mul_right _ hs rw [buffer_forms σ D _ hlt (by rw [hmod]; exact hk)]; rfl · calc s * (D + 1) + (k + 1) < s * (D + 1) + (D + 1) := Nat.add_lt_add_left (Nat.succ_lt_succ hk) _ _ = (s + 1) * (D + 1) := by rw [Nat.succ_mul] _ ≤ σ * (D + 1) := Nat.mul_le_mul_right _ hs /-- 29:C8 — the frame's cardinality clause of Proposition illusion at an instance: two seeds, `D = 17 > 2^4`, so `M = 36 > 2 · 2^{3+1}` for an agent of capacity `3` over two letters — decided by the kernel. -/ theorem illusion_instance : 2 * 2 ^ (3 + 1) < (buffer 2 17).size ∧ 2 ^ (3 + 1) < 17 := by decide /-! ### Corollary asymmetry — a check terminates, and a trace is itself a bounded record -/ /-- 29:C3 — the check of a trace in a universe under a reading is decided by exhaustive evaluation over the `t` objects and the `t²` atoms: a completed check is a terminating computation. -/ def decPasses (T : Trace) (U : Universe) (e : Nat → Nat) : Decidable (Passes T U e) := have d1 : Decidable (∀ i, i < T.t → e i < U.size) := FRC.Shell.decForallLT (fun i => e i < U.size) T.t have d2' : Decidable (∀ i, i < T.t → ∀ j, j < T.t → e i = e j → i = j) := @FRC.Shell.decForallLT (fun i => ∀ j, j < T.t → e i = e j → i = j) (fun i => @FRC.Shell.decForallLT (fun j => e i = e j → i = j) (fun _ => inferInstance) T.t) T.t have d2 : Decidable (∀ i j, i < T.t → j < T.t → e i = e j → i = j) := @decidable_of_iff _ _ ⟨fun h i j hi hj => h i hi j hj, fun h i hi j hj => h i j hi hj⟩ d2' have d3' : Decidable (∀ i, i < T.t → ∀ j, j < T.t → T.atom i j = true → U.form (e i) = some (e j)) := @FRC.Shell.decForallLT (fun i => ∀ j, j < T.t → T.atom i j = true → U.form (e i) = some (e j)) (fun i => @FRC.Shell.decForallLT (fun j => T.atom i j = true → U.form (e i) = some (e j)) (fun _ => inferInstance) T.t) T.t have d3 : Decidable (∀ i j, i < T.t → j < T.t → T.atom i j = true → U.form (e i) = some (e j)) := @decidable_of_iff _ _ ⟨fun h i j hi hj => h i hi j hj, fun h i hi j hj => h i j hi hj⟩ d3' @instDecidableAnd _ _ d1 (@instDecidableAnd _ _ d2 d3) /-- The entries `f 0, …, f (n − 1)` as a list. -/ def rowList (f : Nat → Bool) : Nat → List Bool | 0 => [] | n + 1 => rowList f n ++ [f n] theorem length_append (l m : List Bool) : (l ++ m).length = l.length + m.length := by induction l with | nil => show m.length = 0 + m.length; rw [Nat.zero_add] | cons a l ih => show (l ++ m).length + 1 = (l.length + 1) + m.length; rw [ih, Nat.succ_add] theorem rowList_length (f : Nat → Bool) : ∀ n, (rowList f n).length = n | 0 => rfl | n + 1 => by show (rowList f n ++ [f n]).length = n + 1; rw [length_append, rowList_length f n]; rfl /-- The atom table of a trace, row by row: the record that encodes the check. -/ def record (T : Trace) : Nat → List Bool | 0 => [] | i + 1 => record T i ++ rowList (T.atom i) T.t /-- 29:C3 — Corollary asymmetry: a trace of `t` objects is a record of `t²` symbols, a bounded structural fact has a certifying record, retained by every agent whose capacity covers it. -/ theorem record_length (T : Trace) : ∀ i, (record T i).length = i * T.t | 0 => by rw [Nat.zero_mul]; rfl | i + 1 => by show (record T i ++ rowList (T.atom i) T.t).length = (i + 1) * T.t rw [length_append, record_length T i, rowList_length, Nat.succ_mul] /-- 29:C3 — the record of the whole trace has `t²` symbols. -/ theorem record_square (T : Trace) : (record T T.t).length = T.t * T.t := record_length T T.t end FRC.Formation /-! inlined: FrcCore/Keys/Logic.lean -/ /-! # FrcCore.Keys.Logic — the keyed theorems of the logic theme (ledger migration, task LM19) One declaration per key, `FRC.Ledger.p`, generated by `make_keys.py` from the ledgers' Lean bindings: the theorem that every row carrying the key asserts, proved from the themes alone. The paper's module keeps its declaration `FRC..p` as an alias. Every declaration has no axioms (`check_core_axioms.py`). -/ namespace FRC.Ledger -- Keys of the logic theme (generated by make_keys.py from the ledgers' Lean bindings; edit the ledgers, not this file) /-- p00186 — 00:Z1. G\"odel is vacuous over the finite $\Om$: its theory is complete and decidable, and neither incompleteness theorem has an instance, since $\Om$ interprets no Robinson $\mathsf{Q}$ (25:C1, 25:C2, 25:C3). Incompleteness migrates to the comprehension horizon, the \emph{horizon clause}, as a decomposition (25:G7). Its complexity face is imported (25:G3), its uniform certificate $\Om$-hard (Z3), and its diagonal confined below $t(\M)$ (Z9). -/ theorem p00186 : (∀ (n : Nat) (S : Nat → Nat), (∀ (x : Nat), x < n → S x < n) → (∀ (x y : Nat), x < n → y < n → S x = S y → x = y) → ∀ (z : Nat), z < n → ¬∀ (x : Nat), x < n → S x ≠ z) ∧ (∀ (n : Nat) (D Z : Nat → Bool) (Sg : Nat → Nat → Bool), (∀ (x : Nat), x < n → D x = true → ∃ y, y < n ∧ D y = true ∧ Sg x y = true) → (∀ (x x' y : Nat), x < n → x' < n → D x = true → D x' = true → Sg x y = true → Sg x' y = true → x = x') → (∃ z, z < n ∧ D z = true ∧ Z z = true) → (∀ (x y : Nat), x < n → y < n → D x = true → D y = true → Sg x y = true → Z y = false) → False) ∧ (∀ (M : FRC.Logic.FinStr) (env : Nat → Nat) (δ σ ζ : FRC.Logic.FForm), ¬((∀ (x : Nat), x < M.m → FRC.Logic.Sat M (FRC.Logic.cons x env) δ → ∃ y, y < M.m ∧ FRC.Logic.Sat M (FRC.Logic.cons y env) δ ∧ FRC.Logic.Sat M (FRC.Logic.cons y (FRC.Logic.cons x env)) σ) ∧ (∀ (x x' y : Nat), x < M.m → x' < M.m → FRC.Logic.Sat M (FRC.Logic.cons x env) δ → FRC.Logic.Sat M (FRC.Logic.cons x' env) δ → FRC.Logic.Sat M (FRC.Logic.cons y (FRC.Logic.cons x env)) σ → FRC.Logic.Sat M (FRC.Logic.cons y (FRC.Logic.cons x' env)) σ → x = x') ∧ (∃ z, z < M.m ∧ FRC.Logic.Sat M (FRC.Logic.cons z env) δ ∧ FRC.Logic.Sat M (FRC.Logic.cons z env) ζ) ∧ ∀ (x y : Nat), x < M.m → y < M.m → FRC.Logic.Sat M (FRC.Logic.cons x env) δ → FRC.Logic.Sat M (FRC.Logic.cons y env) δ → FRC.Logic.Sat M (FRC.Logic.cons y (FRC.Logic.cons x env)) σ → ¬FRC.Logic.Sat M (FRC.Logic.cons y env) ζ)) ∧ (∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.FForm) (env : Nat → Nat), FRC.Logic.fval M env φ = true ↔ FRC.Logic.Sat M env φ) ∧ (∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.FForm) (env : Nat → Nat), FRC.Logic.Sat M env φ ∨ FRC.Logic.Sat M env φ.neg) ∧ ∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.FForm) (env : Nat → Nat), ¬(FRC.Logic.Sat M env φ ∧ FRC.Logic.Sat M env φ.neg) := And.intro @FRC.Logic.no_finite_successor (And.intro @FRC.Logic.no_finite_Q (And.intro @FRC.Logic.no_interpretation (And.intro @FRC.Logic.fin_theory_decidable (And.intro @FRC.Logic.fin_theory_complete (@FRC.Logic.fin_theory_consistent))))) /-- p05013 — 5:C2, 29:C10. The pigeonhole (O3): an agent with fewer than $s^{K+1}$ records in a frame of $M>s^{K+1}$ formations holds no injective representation of it, so the frame's cardinality is not certifiable from within. Counterparts 25:D1, 00:A4. -/ theorem p05013 : (∀ (s : Nat), (2 : Nat) ≤ s → ∀ (K : Nat), FRC.Logic.records s K < s ^ (K + (1 : Nat))) ∧ ∀ {N R : Nat}, R < N → ∀ (f : Nat → Nat), (∀ (i : Nat), i < N → f i < R) → (∀ (i j : Nat), i < N → j < N → f i = f j → i = j) → False := And.intro @FRC.Logic.records_lt (@FRC.Logic.no_mirror) /-- p05016 — 5:C5. Horizon separation: halting for machines of bounded space $K$ is decided from above within $|Q|\,K\,s^{K}$ steps (a configuration repeats) and never from within (diagonalisation); Turing's theorem is an external non-existence theorem, classified with Cantor's, not an instance of the bundle. -/ theorem p05016 : (∀ (f : Nat → Nat) (n : Nat), (∀ (y : Nat), y < n → f y < n) → ∀ (x : Nat), x < n → ∃ i j, i < j ∧ j ≤ n ∧ FRC.Logic.iter f x i = FRC.Logic.iter f x j) ∧ ∀ (f : Nat → Nat) (n : Nat), (∀ (y : Nat), y < n → f y < n) → ∀ (h x : Nat), x < n → ((∃ k, FRC.Logic.iter f x k = h) ↔ ∃ k, k ≤ n ∧ FRC.Logic.iter f x k = h) := And.intro @FRC.Logic.repeat_below (@FRC.Logic.halts_iff_halts_below) /-- p05019 — 5:D3. Diagonal normal form: $\{$Eff, Cns, Cmp, IR$\}$ inconsistent (B2), Tarski a variant with the truth predicate for Cmp; the diagonal is a theorem when external --- Cantor's theorem, $n<2^{n}$ on every frame, uncountability, halting --- and a paradox engine only over an internalised registry with completeness demanded. -/ theorem p05019 : ∀ (n : Nat), n < (2 : Nat) ^ n := @FRC.Logic.cantor_finite /-- p05027 — 5:E1. Global choice on a finite universe: with a canonical order, $\operatorname{ch}(A)=\min A$ is a uniform pointwise choice rule; over a fixed finite base AC is a definable theorem; finite products are nonempty without it. -/ theorem p05027 : (∀ (P : Nat → Bool) (n x : Nat), FRC.Logic.leastBelow P n = some x → x < n ∧ P x = true ∧ ∀ (y : Nat), y < x → P y = false) ∧ ∀ (P : Nat → Bool) (n x : Nat), x < n → P x = true → ∃ y, FRC.Logic.leastBelow P n = some y := And.intro @FRC.Logic.leastBelow_spec (@FRC.Logic.leastBelow_some) /-- p05028 — 5:E2. Periodic choice: an equality-periodic family $A_{i+N}=A_i$ has the choice $f(i)=\operatorname{ch}(A_i)$ of the same period; group-periodic families as equivariant surjections $\pi:A\to I$ with equivariant sections. -/ theorem p05028 : ∀ {P Q : Nat → Bool} {n : Nat}, (∀ (x : Nat), x < n → P x = Q x) → FRC.Logic.leastBelow P n = FRC.Logic.leastBelow Q n := @FRC.Logic.leastBelow_congr /-- p05031 — 5:E5. Periodic K\H{o}nig: in a finite digraph with out-degree $\ge1$ the greedy walk repeats a vertex within $|D|+1$ steps and is eventually periodic with period $\le|D|$ --- the pigeonhole on an iteration over finitely many states. -/ theorem p05031 : (∀ (f : Nat → Nat) (n : Nat), (∀ (y : Nat), y < n → f y < n) → ∀ (x : Nat), x < n → ∃ i j, i < j ∧ j ≤ n ∧ FRC.Logic.iter f x i = FRC.Logic.iter f x j) ∧ ∀ (f : Nat → Nat) (n : Nat), (∀ (y : Nat), y < n → f y < n) → ∀ (x : Nat), x < n → ∃ i p, (0 : Nat) < p ∧ p ≤ n ∧ ∀ (k : Nat), FRC.Logic.iter f x (i + k + p) = FRC.Logic.iter f x (i + k) := And.intro @FRC.Logic.repeat_below (@FRC.Logic.eventually_periodic) /-- p25010 — 25:C1, 29:B5. Lemma innocence (i): no finite structure interprets $Q$ --- a model of $Q$ has an injective successor with $0$ outside its range, and on a finite set an injective map is onto. $Q$'s successor axioms alone, with no induction, exclude every finite model. -/ theorem p25010 : (∀ (n : Nat) (S : Nat → Nat), (∀ (x : Nat), x < n → S x < n) → (∀ (x y : Nat), x < n → y < n → S x = S y → x = y) → ∀ (z : Nat), z < n → ∃ x, x < n ∧ S x = z) ∧ ∀ (n : Nat) (S : Nat → Nat), (∀ (x : Nat), x < n → S x < n) → (∀ (x y : Nat), x < n → y < n → S x = S y → x = y) → ∀ (z : Nat), z < n → ¬∀ (x : Nat), x < n → S x ≠ z := And.intro @FRC.Logic.inj_onto (@FRC.Logic.no_finite_successor) /-- p25014 — 25:C5. Tarski scoped: the $m+1$ sentences $\varphi,\neg\varphi,\dots,\neg^{m}\varphi$ outnumber the $m$ elements of $\M$, so every numbering of the sentences by elements of $\M$ gives two of them the same number. Truth in $\M$ is defined externally by a finite table with the evaluation procedure of C2. What fails is the internalisation of truth. -/ theorem p25014 : ∀ (m : Nat) (g : Nat → Nat), (∀ (i : Nat), i < m + (1 : Nat) → g i < m) → ¬∀ (i j : Nat), i < m + (1 : Nat) → j < m + (1 : Nat) → g i = g j → i = j := @FRC.Logic.sentences_outnumber /-- p25015 — 25:D1. Relational diagonal: an agent of storage capacity $K$ with $a^{K} i) ∧ (∀ (T : FRC.Formation.Trace), (FRC.Formation.minimal T).size = T.t) ∧ ∀ (T : FRC.Formation.Trace), (FRC.Formation.minimal T).Closed := And.intro @FRC.Formation.realized (And.intro @FRC.Formation.minimal_size (@FRC.Formation.minimal_closed)) /-- p29011 — 29:C3. The asymmetry: the check of a trace is decided by exhaustive evaluation of its $t^{2}$ atoms and terminates, and the trace is itself a record of $t^{2}$ symbols, retained when $t^{2}\le K$; bounded structural facts are certifiable, the unbounded supply is not (C2). Cited definitions (not proofs): FRC.Formation.decPasses. -/ theorem p29011 : (∀ (T : FRC.Formation.Trace) (i : Nat), (FRC.Formation.record T i).length = i * T.t) ∧ ∀ (T : FRC.Formation.Trace), (FRC.Formation.record T T.t).length = T.t * T.t := And.intro @FRC.Formation.record_length (@FRC.Formation.record_square) /-- p29012 — 29:C4. Corollary symmetry, uncertifiability of the bound: a passed check passes after padding by any number $k$ of fresh formations, in a closed realizing universe of exactly $t+k$ objects, so the passing entails no upper bound; with C10, no record fixes the cardinality. -/ theorem p29012 : (∀ (T : FRC.Formation.Trace) (U : FRC.Formation.Universe) (e : Nat → Nat), FRC.Formation.Passes T U e → ∀ (k : Nat), FRC.Formation.Passes T (FRC.Formation.pad U k) e) ∧ ∀ (T : FRC.Formation.Trace) (U : FRC.Formation.Universe) (e : Nat → Nat), FRC.Formation.Passes T U e → ∀ (k : Nat), (FRC.Formation.Passes T (FRC.Formation.pad (FRC.Formation.minimal T) k) fun i => i) ∧ (FRC.Formation.pad (FRC.Formation.minimal T) k).size = T.t + k ∧ (FRC.Formation.pad (FRC.Formation.minimal T) k).Closed := And.intro @FRC.Formation.passes_pad (@FRC.Formation.realization_at_size) /-- p29014 — 29:C6. Lemma boundary, Case 1: the disjoint double of a closed universe carries the swap, an automorphism without fixed points, of order two; a condition invariant under the swap has an even number of satisfiers, never exactly one; the check passes in the double. -/ theorem p29014 : (∀ (U : FRC.Formation.Universe), U.Closed → ∀ (x : Nat), x < (FRC.Formation.double U).size → (FRC.Formation.double U).form (FRC.Formation.swap U x) = match (FRC.Formation.double U).form x with | some y => some (FRC.Formation.swap U y) | none => none) ∧ (∀ (U : FRC.Formation.Universe) (x : Nat), x < (FRC.Formation.double U).size → FRC.Formation.swap U x ≠ x) ∧ (∀ (U : FRC.Formation.Universe) (x : Nat), x < (FRC.Formation.double U).size → FRC.Formation.swap U (FRC.Formation.swap U x) = x) ∧ (∀ (T : FRC.Formation.Trace) (U : FRC.Formation.Universe) (e : Nat → Nat), FRC.Formation.Passes T U e → FRC.Formation.Passes T (FRC.Formation.double U) e) ∧ (∀ (U : FRC.Formation.Universe) (D : Nat → Bool), (∀ (x : Nat), x < (FRC.Formation.double U).size → D (FRC.Formation.swap U x) = D x) → FRC.Logic.count D (FRC.Formation.double U).size = (2 : Nat) * FRC.Logic.count D U.size) ∧ ∀ (U : FRC.Formation.Universe) (D : Nat → Bool), (∀ (x : Nat), x < (FRC.Formation.double U).size → D (FRC.Formation.swap U x) = D x) → FRC.Logic.count D (FRC.Formation.double U).size ≠ (1 : Nat) := And.intro @FRC.Formation.swap_form (And.intro @FRC.Formation.swap_ne (And.intro @FRC.Formation.swap_swap (And.intro @FRC.Formation.passes_double (And.intro @FRC.Formation.invariant_count_even (@FRC.Formation.no_unique_invariant))))) /-- p29015 — 29:C7. Lemma boundary, Case 2: the minimal realization holds the trace's objects and nothing else, and a datum the trace never forms has no preimage there: descriptive uniqueness is confined to trace-derived objects, so every presentable object is reachable. -/ theorem p29015 : (∀ (T : FRC.Formation.Trace), (FRC.Formation.minimal T).size = T.t) ∧ ∀ (T : FRC.Formation.Trace) (x : Nat), (∀ (i : Nat), i < T.t → T.atom i x = false) → ∀ (y : Nat), y < T.t → (FRC.Formation.minimal T).form y ≠ some x := And.intro @FRC.Formation.minimal_size (@FRC.Formation.no_preimage_in_minimal) /-- p29016 — 29:C8. Proposition illusion (i), (ii): the buffer frame of $\sigma$ seeds and $D$ rounds has $\sigma(D+1)$ formations; every object below level $D$ has a fresh image one level up; $k$ acts from a seed reach level $k$ for $k\le D$. Instance $\sigma=2$, $D=17$: $M=36>2\cdot2^{4}$, $D>2^{4}$. -/ theorem p29016 : (∀ (σ D x : Nat), x < σ * (D + (1 : Nat)) → x % (D + (1 : Nat)) < D → (FRC.Formation.buffer σ D).form x = some (x + (1 : Nat))) ∧ (∀ (σ D x : Nat), x < σ * (D + (1 : Nat)) → x % (D + (1 : Nat)) < D → x + (1 : Nat) < σ * (D + (1 : Nat)) ∧ (x + (1 : Nat)) % (D + (1 : Nat)) = x % (D + (1 : Nat)) + (1 : Nat)) ∧ (∀ (σ D s : Nat), s < σ → ∀ (k : Nat), k ≤ D → FRC.Formation.chain σ D s k = some (s * (D + (1 : Nat)) + k)) ∧ (∀ (σ D s k : Nat), s < σ → k < D → ∃ x y, FRC.Formation.chain σ D s k = some x ∧ (FRC.Formation.buffer σ D).form x = some y ∧ FRC.Formation.chain σ D s (k + (1 : Nat)) = some y ∧ x < y ∧ y < (FRC.Formation.buffer σ D).size) ∧ (2 : Nat) * (2 : Nat) ^ ((3 : Nat) + (1 : Nat)) < (FRC.Formation.buffer (2 : Nat) (17 : Nat)).size ∧ (2 : Nat) ^ ((3 : Nat) + (1 : Nat)) < (17 : Nat) := And.intro @FRC.Formation.buffer_forms (And.intro @FRC.Formation.buffer_fresh (And.intro @FRC.Formation.chain_level (And.intro @FRC.Formation.illusion (@FRC.Formation.illusion_instance)))) /-- p29022 — 29:E2. Certificate conservativity: a $\Delta_0$ sentence takes its standard value in every frame beyond its bound (5:B6); every instance of a schema below the bound is decided by evaluation; induction transfers instance-wise (B6). Derivations through infinitary principles are kept as derivability facts: a reading. -/ theorem p29022 : (∀ (N : Nat) (φ : FRC.Logic.Form) (env : Nat → Nat), FRC.Logic.boundF env φ < N → FRC.Logic.evalF? N env φ = FRC.Logic.evalF env φ) ∧ (∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.FForm) (env : Nat → Nat), FRC.Logic.fval M env φ = true ↔ FRC.Logic.Sat M env φ) ∧ (∀ (n : Nat) (P : Nat → Bool), P (0 : Nat) = true → (∀ (x : Nat), x + (1 : Nat) < n → P x = true → P (x + (1 : Nat)) = true) → ∀ (x : Nat), x < n → P x = true) ∧ ∀ (P : Nat → Bool) (n x : Nat), FRC.Logic.leastBelow P n = some x → x < n ∧ P x = true ∧ ∀ (y : Nat), y < x → P y = false := And.intro @FRC.Logic.stable (And.intro @FRC.Logic.fin_theory_decidable (And.intro @FRC.Formation.finite_induction (@FRC.Logic.leastBelow_spec))) /-- p29024 — 29:E4. Effective determinacy on a finite frame: subsets and relations are finitely many, and the full second-order theory is decided by exhaustive evaluation over them. The finite direction of 5:D8. -/ theorem p29024 : (∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.SForm) (env senv renv : Nat → Nat), FRC.Logic.sval2 M env senv renv φ = true ↔ FRC.Logic.Sat2 M env senv renv φ) ∧ (∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.SForm) (env senv renv : Nat → Nat), FRC.Logic.Sat2 M env senv renv φ ∨ FRC.Logic.Sat2 M env senv renv φ.neg) ∧ ∀ (M : FRC.Logic.FinStr) (φ : FRC.Logic.SForm) (env senv renv : Nat → Nat), ¬(FRC.Logic.Sat2 M env senv renv φ ∧ FRC.Logic.Sat2 M env senv renv φ.neg) := And.intro @FRC.Logic.so_theory_decidable (And.intro @FRC.Logic.so_theory_complete (@FRC.Logic.so_theory_consistent)) /-- p29026 — 29:X1. \textbf{``One can always continue''} is derived, not posited: in a buffered finite frame every act on a reachable object succeeds and no enumeration below the horizon is exhausted (C8), while no check witnesses an end (C6, C7). Rests on C2, C6--C8. -/ theorem p29026 : (∀ (σ D s k : Nat), s < σ → k < D → ∃ x y, FRC.Formation.chain σ D s k = some x ∧ (FRC.Formation.buffer σ D).form x = some y ∧ FRC.Formation.chain σ D s (k + (1 : Nat)) = some y ∧ x < y ∧ y < (FRC.Formation.buffer σ D).size) ∧ (∀ (U : FRC.Formation.Universe) (D : Nat → Bool), (∀ (x : Nat), x < (FRC.Formation.double U).size → D (FRC.Formation.swap U x) = D x) → FRC.Logic.count D (FRC.Formation.double U).size ≠ (1 : Nat)) ∧ ∀ (T : FRC.Formation.Trace) (x : Nat), (∀ (i : Nat), i < T.t → T.atom i x = false) → ∀ (y : Nat), y < T.t → (FRC.Formation.minimal T).form y ≠ some x := And.intro @FRC.Formation.illusion (And.intro @FRC.Formation.no_unique_invariant (@FRC.Formation.no_preimage_in_minimal)) /-- p29027 — 29:X2. \textbf{The finite ontology loses no proof practice:} induction is a theorem of every finite frame (B6) and every executed verification is a bounded instance (E2). Rests on B6, E2. -/ theorem p29027 : (∀ (n : Nat) (P : Nat → Bool), P (0 : Nat) = true → (∀ (x : Nat), x + (1 : Nat) < n → P x = true → P (x + (1 : Nat)) = true) → ∀ (x : Nat), x < n → P x = true) ∧ ∀ (N : Nat) (φ : FRC.Logic.Form) (env : Nat → Nat), FRC.Logic.boundF env φ < N → FRC.Logic.evalF? N env φ = FRC.Logic.evalF env φ := And.intro @FRC.Formation.finite_induction (@FRC.Logic.stable) -- end keys end FRC.Ledger /-! FrcCore/Godel.lean -/ /-! # 25-göd — incompleteness without infinity: the ledger predicates with no axioms Predicates of the ledger of *Incompleteness Without Infinity* (tree `25-godel-20260614`). What the paper proves about a fixed finite structure is finite mathematics, and its counting core is proved here on the kernel alone. * 25:C1 — on a finite carrier an injective map is onto, so no successor of `Q` lives there. * 25:C5 — `m + 1` sentences admit no injective numbering into `m` elements. * 25:D1 — a part with fewer storage states than the structure has elements identifies two of them. * 25:D4 — a term evaluated by table lookups takes the same value in every table that agrees on the entries consulted (the trace argument of the wrap lemma). * 25:E1 — every closed term over `1` and `+` with `ℓ` leaves has the value `ℓ mod p`. * 25:E2 — the records of length at most `B` number fewer than `a^(B+1)`, and the certified fraction falls below every `1/N`. * 25:F1, 25:F3 — a formula's truth depends only on variables that occur in it. It depends on fewer coordinates than it has symbols, and no sentence has a subformula that reads a tuple as long as the sentence. * 25:F2 — the diagonal formula is longer than the scale of its bound tuple and than the scale its matrix reads. * 25:F4 — an injective coding of `a^n` strings into `k`-tuples needs `a^n ≤ m^k`. * 25:G4 — the uniform pairing prefix decides what the coded prefix decides. The formulas are those of the signature of `M_p` (`0`, `1`, `+`, `×`). Every declaration prints "does not depend on any axioms". Since the ledger migration (task LM17) the counting core (25:C1, C5, D1, F4 and the Boolean bookkeeping) lives in the logic theme (`Theme/Logic.lean`, namespace `FRC.Logic`); every old name stays as an alias. -/ namespace FRC.Godel section open FRC.Logic /-! ### Boolean bookkeeping, from the definitions -/ /-! ### 25:C1 — on a finite carrier an injective map is onto -/ /-! ### 25:D1 — the part cannot hold the whole -/ /-! ### 25:D4, 25:E1 — closed terms, their values, and the entries an evaluation consults -/ /-- Closed terms over one constant and one binary operation: the full binary trees. -/ inductive Tm where | one : Tm | op : Tm → Tm → Tm /-- The value of a term in the structure with the constant read as `u` and the operation's table `f`. -/ def val (u : Nat) (f : Nat → Nat → Nat) : Tm → Nat | .one => u | .op s t => f (val u f s) (val u f t) /-- `g` agrees with `f` on every table entry the evaluation of the term in `(u, f)` consults. -/ def Agree (u : Nat) (f g : Nat → Nat → Nat) : Tm → Prop | .one => True | .op s t => Agree u f g s ∧ Agree u f g t ∧ g (val u f s) (val u f t) = f (val u f s) (val u f t) /-- The number of leaves of a term. -/ def leaves : Tm → Nat | .one => 1 | .op s t => leaves s + leaves t /-- The number of table lookups the evaluation of a term performs: one per operation. -/ def lookups : Tm → Nat | .one => 0 | .op s t => lookups s + lookups t + 1 /-- 25:D4 (Lemma wrap (2), the trace argument) — a structure that agrees with `M` on the entries the evaluation consults gives the term the same value: the verification succeeds there step for step. -/ theorem trace_transport (u : Nat) (f g : Nat → Nat → Nat) : ∀ t : Tm, Agree u f g t → val u g t = val u f t | .one, _ => rfl | .op s t, ⟨hs, ht, e⟩ => by show g (val u g s) (val u g t) = f (val u f s) (val u f t) rw [trace_transport u f g s hs, trace_transport u f g t ht]; exact e /-- 25:D4 (Lemma wrap (2), the end sentence) — an equation verified by evaluation in `M` is true in every other table that agrees with `M` on the cited entries: the certificate keeps its warrant in the small world. -/ theorem wrap_equation (u : Nat) (f g : Nat → Nat → Nat) (s t : Tm) (hs : Agree u f g s) (ht : Agree u f g t) (h : val u f s = val u f t) : val u g s = val u g t := by rw [trace_transport u f g s hs, trace_transport u f g t ht]; exact h /-- 25:D4 (Lemma wrap (2), the size of the trace) — the evaluation of a term with `ℓ` leaves performs `ℓ − 1` lookups. -/ theorem lookups_succ : ∀ t : Tm, lookups t + 1 = leaves t | .one => rfl | .op s t => by show lookups s + lookups t + 1 + 1 = leaves s + leaves t rw [← lookups_succ s, ← lookups_succ t] exact (FRC.Nat.add_add_add_comm (lookups s) 1 (lookups t) 1).symm /-- 25:E1 (Lemma abundance, the value) — in `M_p` the closed term over `1` and `+` with `ℓ` leaves has the value `ℓ mod p`, whatever its shape. -/ theorem value_leaves (p : Nat) (hp : 0 < p) : ∀ t : Tm, val (1 % p) (fun x y => (x + y) % p) t = leaves t % p | .one => rfl | .op s t => by show (val (1 % p) (fun x y => (x + y) % p) s + val (1 % p) (fun x y => (x + y) % p) t) % p = (leaves s + leaves t) % p rw [value_leaves p hp s, value_leaves p hp t] exact (FRC.Nat.add_mod (leaves s) (leaves t) p hp).symm /-- 25:E1 (Lemma abundance, the cohort) — any two terms with the same number of leaves give a true equation of `M_p`. -/ theorem equal_leaves_equal_value (p : Nat) (hp : 0 < p) (s t : Tm) (h : leaves s = leaves t) : val (1 % p) (fun x y => (x + y) % p) s = val (1 % p) (fun x y => (x + y) % p) t := by rw [value_leaves p hp s, value_leaves p hp t, h] /-! ### 25:E2 — the reach bound -/ /-- 25:E2 (Proposition reach, the count) — the records of length at most `B` over `a ≥ 2` letters number fewer than `a^(B+1)`. -/ theorem records_lt (a : Nat) (ha : 2 ≤ a) (B : Nat) : FRC.Logic.records a B < a ^ (B + 1) := FRC.Logic.records_lt a ha B /-- 25:E2 (Proposition reach, the vanishing fraction in finite form) — against a cohort of `2^L` truths the records of length at most `B` certify a fraction below `1/N` once `L ≥ a^(B+1)·N`: their number times `N` is below `2^L`. -/ theorem reach_vanishes (a : Nat) (ha : 2 ≤ a) (B N L : Nat) (h : a ^ (B + 1) * N ≤ L) : FRC.Logic.records a B * N < 2 ^ L := Nat.lt_of_le_of_lt (Nat.le_trans (Nat.mul_le_mul_right N (Nat.le_of_lt (FRC.Logic.records_lt a ha B))) h) Nat.lt_two_pow_self /-! ### 25:F1, 25:F3 — mention cost: truth depends only on variables that occur -/ /-- Terms with variables (de Bruijn indices) over the signature of `M_p`. -/ inductive VTm where | var : Nat → VTm | zero : VTm | one : VTm | add : VTm → VTm → VTm | mul : VTm → VTm → VTm /-- First-order formulas: equations, negation, conjunction, and the quantifier over the whole structure (the bound variable is variable `0` of the body, the others shift up). -/ inductive Fm where | eq : VTm → VTm → Fm | neg : Fm → Fm | conj : Fm → Fm → Fm | all : Fm → Fm /-- The value of a term in `M_p` under an assignment. -/ def tval (p : Nat) (env : Nat → Nat) : VTm → Nat | .var i => env i | .zero => 0 | .one => 1 % p | .add s t => (tval p env s + tval p env t) % p | .mul s t => (tval p env s * tval p env t) % p /-- Truth in `M_p` under an assignment: the quantifier ranges over the `p` elements. -/ def holds (p : Nat) (env : Nat → Nat) : Fm → Bool | .eq s t => decide (tval p env s = tval p env t) | .neg φ => !(holds p env φ) | .conj φ ψ => holds p env φ && holds p env ψ | .all φ => allBelow (fun x => holds p (cons x env) φ) p /-- Variable `i` occurs in the term. -/ def occT (i : Nat) : VTm → Bool | .var j => decide (j = i) | .zero => false | .one => false | .add s t => occT i s || occT i t | .mul s t => occT i s || occT i t /-- Variable `i` occurs free in the formula. -/ def occ (i : Nat) : Fm → Bool | .eq s t => occT i s || occT i t | .neg φ => occ i φ | .conj φ ψ => occ i φ || occ i ψ | .all φ => occ (i + 1) φ /-- The length of a term, in symbols. -/ def tsize : VTm → Nat | .var _ => 1 | .zero => 1 | .one => 1 | .add s t => tsize s + tsize t + 1 | .mul s t => tsize s + tsize t + 1 /-- The length of a formula, in symbols. -/ def size : Fm → Nat | .eq s t => tsize s + tsize t + 1 | .neg φ => size φ + 1 | .conj φ ψ => size φ + size ψ + 1 | .all φ => size φ + 1 theorem tval_congr (p : Nat) {env env' : Nat → Nat} : ∀ t : VTm, (∀ i, occT i t = true → env i = env' i) → tval p env t = tval p env' t | .var j, h => h j (decide_eq_true rfl) | .zero, _ => rfl | .one, _ => rfl | .add s t, h => by show (tval p env s + tval p env t) % p = (tval p env' s + tval p env' t) % p rw [tval_congr p s (fun i hi => h i (or_intro_left hi)), tval_congr p t (fun i hi => h i (or_intro_right hi))] | .mul s t, h => by show (tval p env s * tval p env t) % p = (tval p env' s * tval p env' t) % p rw [tval_congr p s (fun i hi => h i (or_intro_left hi)), tval_congr p t (fun i hi => h i (or_intro_right hi))] /-- 25:F1 (Lemma mention, the coincidence form) — two assignments that agree on the variables occurring free in a formula give it the same truth value in `M_p`. -/ theorem holds_congr (p : Nat) : ∀ (φ : Fm) {env env' : Nat → Nat}, (∀ i, occ i φ = true → env i = env' i) → holds p env φ = holds p env' φ | .eq s t, env, env', h => by show decide (tval p env s = tval p env t) = decide (tval p env' s = tval p env' t) rw [tval_congr p s (fun i hi => h i (or_intro_left hi)), tval_congr p t (fun i hi => h i (or_intro_right hi))] | .neg φ, env, env', h => by show (!(holds p env φ)) = (!(holds p env' φ)) rw [holds_congr p φ h] | .conj φ ψ, env, env', h => by show (holds p env φ && holds p env ψ) = (holds p env' φ && holds p env' ψ) rw [holds_congr p φ (fun i hi => h i (or_intro_left hi)), holds_congr p ψ (fun i hi => h i (or_intro_right hi))] | .all φ, env, env', h => by show allBelow (fun x => holds p (cons x env) φ) p = allBelow (fun x => holds p (cons x env') φ) p exact allBelow_congr (fun x _ => holds_congr p φ (fun i hi => match i, hi with | 0, _ => rfl | j + 1, hj => h j hj)) /-- The assignment changed at one coordinate. -/ def upd (env : Nat → Nat) (i v : Nat) : Nat → Nat := fun j => if j = i then v else env j /-- 25:F1 (Lemma mention) — if the truth of a formula in `M_p` depends on coordinate `i` (reassigning it changes the truth value), then variable `i` occurs in the formula. -/ theorem mention (p : Nat) (φ : Fm) (env : Nat → Nat) (i v : Nat) (hdep : holds p (upd env i v) φ ≠ holds p env φ) : occ i φ = true := match h : occ i φ with | true => rfl | false => absurd (holds_congr p φ (fun j hj => match Nat.decEq j i with | isTrue e => Bool.noConfusion ((e ▸ hj : occ i φ = true).symm.trans h) | isFalse e => (ite_eq_right e : (if j = i then v else env j) = env j))) hdep /-! #### counting the coordinates a formula can read -/ theorem tcount_le : ∀ (t : VTm) (N : Nat), count (fun i => occT i t) N ≤ tsize t | .var j, N => (count_single j N).1 | .zero, N => by show count (fun _ => false) N ≤ 1; rw [count_false N]; exact Nat.zero_le 1 | .one, N => by show count (fun _ => false) N ≤ 1; rw [count_false N]; exact Nat.zero_le 1 | .add s t, N => Nat.le_trans (count_or_le (fun i => occT i s) (fun i => occT i t) N) (Nat.le_succ_of_le (Nat.add_le_add (tcount_le s N) (tcount_le t N))) | .mul s t, N => Nat.le_trans (count_or_le (fun i => occT i s) (fun i => occT i t) N) (Nat.le_succ_of_le (Nat.add_le_add (tcount_le s N) (tcount_le t N))) theorem fcount_le : ∀ (φ : Fm) (N : Nat), count (fun i => occ i φ) N ≤ size φ | .eq s t, N => Nat.le_trans (count_or_le (fun i => occT i s) (fun i => occT i t) N) (Nat.le_succ_of_le (Nat.add_le_add (tcount_le s N) (tcount_le t N))) | .neg φ, N => Nat.le_succ_of_le (fcount_le φ N) | .conj φ ψ, N => Nat.le_trans (count_or_le (fun i => occ i φ) (fun i => occ i ψ) N) (Nat.le_succ_of_le (Nat.add_le_add (fcount_le φ N) (fcount_le ψ N))) | .all φ, N => Nat.le_succ_of_le (Nat.le_trans (count_shift (fun i => occ i φ) N) (fcount_le φ (N + 1))) /-- 25:F1 (Lemma mention, the arity) — a formula in which the `N` variables `0, …, N − 1` occur has length at least `N`. -/ theorem arity_le_size (φ : Fm) (N : Nat) (h : ∀ i, i < N → occ i φ = true) : N ≤ size φ := (count_full h) ▸ fcount_le φ N /-- 25:F1, 25:F2 (Lemma mention, the cost) — a formula whose truth in `M_p` depends on all `N` coordinates of a tuple (the variables `0, …, N − 1`) has length at least `N`. -/ theorem mention_cost (p : Nat) (φ : Fm) (N : Nat) (h : ∀ i, i < N → ∃ env v, holds p (upd env i v) φ ≠ holds p env φ) : N ≤ size φ := arity_le_size φ N (fun i hi => match h i hi with | ⟨env, v, hdep⟩ => mention p φ env i v hdep) theorem fcount_lt : ∀ (φ : Fm) (N : Nat), count (fun i => occ i φ) N < size φ | .eq s t, N => Nat.lt_succ_of_le (Nat.le_trans (count_or_le (fun i => occT i s) (fun i => occT i t) N) (Nat.add_le_add (tcount_le s N) (tcount_le t N))) | .neg φ, N => Nat.lt_succ_of_lt (fcount_lt φ N) | .conj φ ψ, N => Nat.lt_succ_of_le (Nat.le_trans (count_or_le (fun i => occ i φ) (fun i => occ i ψ) N) (Nat.add_le_add (Nat.le_of_lt (fcount_lt φ N)) (Nat.le_of_lt (fcount_lt ψ N)))) | .all φ, N => Nat.lt_succ_of_lt (Nat.lt_of_le_of_lt (count_shift (fun i => occ i φ) N) (fcount_lt φ (N + 1))) /-- 25:F3 (Corollary quotation, the arity) — a formula in which the `N` variables `j, …, j + N − 1` occur has more than `N` symbols: a formula's arity is below its length. -/ theorem arity_lt_size (φ : Fm) (j N : Nat) (h : ∀ i, i < N → occ (i + j) φ = true) : N < size φ := have h1 : count (fun i => occ (i + j) φ) N = N := count_full h Nat.lt_of_le_of_lt (Nat.le_trans (Nat.le_of_eq h1.symm) (count_shift_by j (fun i => occ i φ) N)) (fcount_lt φ (N + j)) /-- 25:F3 (Corollary quotation, the cost) — a formula whose truth in `M_p` depends on all `N` coordinates of a tuple, the variables `j, …, j + N − 1`, has more than `N` symbols. -/ theorem mention_cost_lt (p : Nat) (φ : Fm) (j N : Nat) (h : ∀ i, i < N → ∃ env v, holds p (upd env (i + j) v) φ ≠ holds p env φ) : N < size φ := arity_lt_size φ j N (fun i hi => match h i hi with | ⟨env, v, hdep⟩ => mention p φ env (i + j) v hdep) /-- `Subformula ψ φ`: `ψ` is a subformula of `φ`. -/ inductive Subformula (ψ : Fm) : Fm → Prop where | refl : Subformula ψ ψ | neg {φ : Fm} : Subformula ψ φ → Subformula ψ (.neg φ) | conjL {φ χ : Fm} : Subformula ψ φ → Subformula ψ (.conj φ χ) | conjR {φ χ : Fm} : Subformula ψ χ → Subformula ψ (.conj φ χ) | all {φ : Fm} : Subformula ψ φ → Subformula ψ (.all φ) theorem sub_size {ψ : Fm} : ∀ {φ : Fm}, Subformula ψ φ → size ψ ≤ size φ | _, .refl => Nat.le_refl _ | _, .neg h => Nat.le_succ_of_le (sub_size h) | .conj φ χ, .conjL h => Nat.le_succ_of_le (Nat.le_trans (sub_size h) (Nat.le_add_right (size φ) (size χ))) | .conj φ χ, .conjR h => Nat.le_succ_of_le (Nat.le_trans (sub_size h) (Nat.le_add_left (size χ) (size φ))) | _, .all h => Nat.le_succ_of_le (sub_size h) /-- 25:F3 (Corollary quotation) — no sentence `lam` contains a subformula whose truth depends on all coordinates of a tuple of arity `N ≥ |lam|`, wherever the tuple's variables `j, …, j + N − 1` sit in the subformula's frame: the subformula would have more than `N` symbols, and it is no longer than `lam`. -/ theorem no_self_reading (p : Nat) {ψ lam : Fm} (hsub : Subformula ψ lam) (j N : Nat) (hN : size lam ≤ N) : ¬ ∀ i, i < N → ∃ env v, holds p (upd env (i + j) v) ψ ≠ holds p env ψ := fun h => Nat.lt_irrefl N (Nat.lt_of_lt_of_le (mention_cost_lt p ψ j N h) (Nat.le_trans (sub_size hsub) hN)) /-! ### 25:F2 — the diagonal template does not fit at any scale -/ /-- `∃ x, φ`, written with the language's one quantifier: `¬ ∀ x, ¬ φ`. -/ def ex (φ : Fm) : Fm := .neg (.all (.neg φ)) /-- A block of `n` existential quantifiers in front of a formula. -/ def exBlock : Nat → Fm → Fm | 0, φ => φ | n + 1, φ => ex (exBlock n φ) /-- 25:F1 (Lemma mention, the quantifier block) — a block binding an `n`-tuple contributes `3n` symbols in this syntax, at least `n`. -/ theorem size_exBlock : ∀ (n : Nat) (φ : Fm), size (exBlock n φ) = size φ + 3 * n | 0, _ => rfl | n + 1, φ => by show size (exBlock n φ) + 1 + 1 + 1 = size φ + 3 * (n + 1) rw [size_exBlock n φ, Nat.mul_succ]; rfl /-- 25:F2 (Theorem nocompress, the accounting) — the diagonal formula `δ = ∃ v (Diag_N ∧ θ)`, with a block of `N` quantifiers and a diagonal relation whose truth depends on all `2N` coordinates, has length at least `2N + |θ| + 3N`: `2N` for the relation (mention cost), then `θ`, and three symbols for each quantifier of the block (the paper counts one, which gives its `3N + |θ|`). -/ theorem template_size (p N : Nat) (diag θ : Fm) (hdep : ∀ i, i < 2 * N → ∃ env v, holds p (upd env i v) diag ≠ holds p env diag) : 2 * N + size θ + 3 * N ≤ size (exBlock N (.conj diag θ)) := by have h2 : 2 * N ≤ size diag := mention_cost p diag (2 * N) hdep rw [size_exBlock] show 2 * N + size θ + 3 * N ≤ size diag + size θ + 1 + 3 * N exact Nat.add_le_add_right (Nat.le_trans (Nat.add_le_add_right h2 (size θ)) (Nat.le_succ _)) (3 * N) /-- 25:F2 (Theorem nocompress, the scale) — a formula that binds an `N`-tuple, `N ≥ 1`, is longer than `N`: the diagonal formula `∃ v (Diag_N ∧ θ)` has no code in `M^N`. The block alone gives this clause; no hypothesis on `Diag_N` or `θ` enters. -/ theorem no_template (N : Nat) (hN : 1 ≤ N) (φ : Fm) : ¬ size (exBlock N φ) ≤ N := fun hle => by rw [size_exBlock] at hle have h3 : 3 * N ≤ N := Nat.le_trans (Nat.le_add_left (3 * N) (size φ)) hle have h4 : N + 1 ≤ 3 * N := by have : N + N ≤ 3 * N := by rw [← Nat.two_mul]; exact Nat.mul_le_mul_right N (by decide) exact Nat.le_trans (Nat.add_le_add_left hN N) this exact Nat.not_succ_le_self N (Nat.le_trans h4 h3) /-- 25:F2 (Theorem nocompress, splitting the scales) — if `θ` reads all `N₂` coordinates of its argument (the non-degeneracy clause, at the scale `N₂` of the code of the fixed point), the diagonal formula is longer than `N₂`, whatever the scale `N` of its own block: here the mention cost is what excludes the instance. -/ theorem split_scale (p N N₂ : Nat) (diag θ : Fm) (hθ : ∀ i, i < N₂ → ∃ env v, holds p (upd env i v) θ ≠ holds p env θ) : N₂ < size (exBlock N (.conj diag θ)) := by have h : N₂ ≤ size θ := mention_cost p θ N₂ hθ rw [size_exBlock] show N₂ < size diag + size θ + 1 + 3 * N exact Nat.lt_of_le_of_lt h (Nat.lt_of_lt_of_le (Nat.lt_succ_of_le (Nat.le_add_left (size θ) (size diag))) (Nat.le_add_right _ (3 * N))) /-! ### 25:F4 — density does not rescue the template -/ /-! ### 25:G4 — the prefix simulation -/ /-- The coded prefix evaluated directly over a structure of `m` elements: `true` codes `∀`, `false` codes `∃`; the matrix `ψ` reads the chosen values (the last chosen first). -/ def direct (m : Nat) (ψ : List Nat → Bool) : List Bool → List Nat → Bool | [], acc => ψ acc | true :: pat, acc => allBelow (fun x => direct m ψ pat (x :: acc)) m | false :: pat, acc => anyBelow (fun x => direct m ψ pat (x :: acc)) m /-- The uniform prefix `∀ y₁ ∃ x₁ … ∀ y_d ∃ x_d` with the clause `x_i = y_i` conjoined at the coded universal positions and the matrix read on the `x`s; `c` carries the clauses collected so far. -/ def paired (m : Nat) (ψ : List Nat → Bool) : List Bool → List Nat → Bool → Bool | [], acc, c => c && ψ acc | q :: pat, acc, c => allBelow (fun y => anyBelow (fun x => paired m ψ pat (x :: acc) (c && (!q || decide (x = y)))) m) m /-- 25:G4 (Lemma prefix) — the prefix simulation: over a structure of `m ≥ 1` elements the uniform pairing prefix with the copy clauses decides exactly what the coded prefix `Q₁ … Q_d` decides, for every pattern and every matrix. -/ theorem prefix_simulation (m : Nat) (hm : 0 < m) (ψ : List Nat → Bool) : ∀ (pat : List Bool) (acc : List Nat) (c : Bool), paired m ψ pat acc c = (c && direct m ψ pat acc) | [], _, _ => rfl | true :: pat, acc, c => by show allBelow (fun y => anyBelow (fun x => paired m ψ pat (x :: acc) (c && (!true || decide (x = y)))) m) m = (c && allBelow (fun x => direct m ψ pat (x :: acc)) m) rw [← allBelow_and_const c (fun x => direct m ψ pat (x :: acc)) m hm] refine allBelow_congr (fun y hy => ?_) have h1 : anyBelow (fun x => paired m ψ pat (x :: acc) (c && (!true || decide (x = y)))) m = anyBelow (fun x => (c && decide (x = y)) && direct m ψ pat (x :: acc)) m := anyBelow_congr (fun x _ => prefix_simulation m hm ψ pat (x :: acc) (c && decide (x = y))) rw [h1, anyBelow_pick c (fun x => direct m ψ pat (x :: acc)) y m, ite_eq_left hy] | false :: pat, acc, c => by show allBelow (fun y => anyBelow (fun x => paired m ψ pat (x :: acc) (c && (!false || decide (x = y)))) m) m = (c && anyBelow (fun x => direct m ψ pat (x :: acc)) m) have h1 : ∀ y, anyBelow (fun x => paired m ψ pat (x :: acc) (c && (!false || decide (x = y)))) m = (c && anyBelow (fun x => direct m ψ pat (x :: acc)) m) := fun y => by rw [← anyBelow_and_const c (fun x => direct m ψ pat (x :: acc)) m] refine anyBelow_congr (fun x _ => ?_) have h2 : paired m ψ pat (x :: acc) (c && (!false || decide (x = y))) = ((c && true) && direct m ψ pat (x :: acc)) := prefix_simulation m hm ψ pat (x :: acc) (c && true) rw [and_true' c] at h2 exact h2 rw [allBelow_congr (fun y _ => h1 y)] exact allBelow_const _ m hm /-- 25:G4 (Lemma prefix, the statement) — with no clause collected, the pairing prefix equals the coded prefix. -/ theorem prefix_simulation_closed (m : Nat) (hm : 0 < m) (ψ : List Nat → Bool) (pat : List Bool) : paired m ψ pat [] true = direct m ψ pat [] := prefix_simulation m hm ψ pat [] true /-! ## Old names (ledger migration, task LM17): the declarations moved to the themes, each under its old name -/ end section aliases variable {p : Nat} [Pos p] {κ : Nat} {g : Shell p} open FRC.Logic (allBelow allBelow_congr cons) theorem or_intro_left {a b : Bool} (h : a = true) : (a || b) = true := FRC.Logic.or_intro_left h theorem or_intro_right {a b : Bool} (h : b = true) : (a || b) = true := FRC.Logic.or_intro_right h theorem and_true' (c : Bool) : (c && true) = c := FRC.Logic.and_true' c theorem and_false' (c : Bool) : (c && false) = false := FRC.Logic.and_false' c theorem and_self' (c : Bool) : (c && c) = c := FRC.Logic.and_self' c theorem or_false' (c : Bool) : (c || false) = c := FRC.Logic.or_false' c theorem and_assoc' (a b c : Bool) : ((a && b) && c) = (a && (b && c)) := FRC.Logic.and_assoc' a b c /-- 25:C1 (Proposition noQ, the pigeonhole) — on `[0, n)` an injective map is onto: every `z < n` is a value. -/ theorem inj_onto (n : Nat) (S : Nat → Nat) (hS : ∀ x, x < n → S x < n) (hinj : ∀ x y, x < n → y < n → S x = S y → x = y) (z : Nat) (hz : z < n) : ∃ x, x < n ∧ S x = z := FRC.Logic.inj_onto n S hS hinj z hz /-- 25:C1 (Proposition noQ) — no successor of `Q` on a finite carrier: no map of `[0, n)` into itself is injective and omits an element, so no finite structure is a model of `Q`. -/ theorem no_finite_successor (n : Nat) (S : Nat → Nat) (hS : ∀ x, x < n → S x < n) (hinj : ∀ x y, x < n → y < n → S x = S y → x = y) (z : Nat) (hz : z < n) : ¬ ∀ x, x < n → S x ≠ z := FRC.Logic.no_finite_successor n S hS hinj z hz /-- 25:D1 (Theorem part) — an agent with `R` storage states in a structure of `m > R` elements has no injective encoding: every reading `ρ : [0, m) → [0, R)` identifies two elements. -/ theorem part_collides {m R : Nat} (hR : R < m) (ρ : Nat → Nat) (hρ : ∀ i, i < m → ρ i < R) : ¬ ∀ i j, i < m → j < m → ρ i = ρ j → i = j := FRC.Logic.part_collides hR ρ hρ /-- 25:C5 (Remark Tarski scoped, the count) — `m + 1` sentences, indexed `0, …, m` (the row's sentences `φ, ¬φ, …, ¬^m φ`), admit no injective numbering into a structure of `m` elements. -/ theorem sentences_outnumber (m : Nat) (g : Nat → Nat) (hg : ∀ i, i < m + 1 → g i < m) : ¬ ∀ i j, i < m + 1 → j < m + 1 → g i = g j → i = j := FRC.Logic.sentences_outnumber m g hg /-- The number of `i < n` with `f i = true`. -/ @[reducible] def count (f : Nat → Bool) : Nat → Nat := FRC.Logic.count f theorem count_full {f : Nat → Bool} : ∀ {n : Nat}, (∀ i, i < n → f i = true) → count f n = n := FRC.Logic.count_full theorem cond_or_le (a b : Bool) : cond (a || b) 1 0 ≤ cond a 1 0 + cond b 1 0 := FRC.Logic.cond_or_le a b theorem count_or_le (f g : Nat → Bool) : ∀ n, count (fun i => f i || g i) n ≤ count f n + count g n := FRC.Logic.count_or_le f g theorem count_shift (f : Nat → Bool) : ∀ n, count (fun i => f (i + 1)) n ≤ count f (n + 1) := FRC.Logic.count_shift f theorem count_false : ∀ n, count (fun _ => false) n = 0 := FRC.Logic.count_false theorem count_single (j : Nat) : ∀ n, count (fun i => decide (j = i)) n ≤ 1 ∧ (n ≤ j → count (fun i => decide (j = i)) n = 0) := FRC.Logic.count_single j theorem count_shift_by : ∀ (j : Nat) (f : Nat → Bool) (N : Nat), count (fun i => f (i + j)) N ≤ count f (N + j) := FRC.Logic.count_shift_by /-- 25:F4 (Lemma density, the count) — an injective coding of the `a^n` strings of length `n` into `k`-tuples over `m` elements needs `a^n ≤ m^k`. -/ theorem dense_coding {a n m k : Nat} (c : Nat → Nat) (hc : ∀ i, i < a ^ n → c i < m ^ k) (hinj : ∀ i j, i < a ^ n → j < a ^ n → c i = c j → i = j) : a ^ n ≤ m ^ k := FRC.Logic.dense_coding c hc hinj /-- A strict power step: `m < b` gives `m^(k+1) < b^(k+1)`. -/ theorem pow_lt_pow_base {m b : Nat} (h : m < b) : ∀ k : Nat, m ^ (k + 1) < b ^ (k + 1) := FRC.Logic.pow_lt_pow_base h /-- 25:F4 (Lemma density, the digit form) — if `m` has at most `d` digits in base `a` (`m < a^d`), a coding of the strings of length `n` by tuples of `k+1` coordinates with `a^n ≤ m^(k+1)` has `n < d·(k+1)`: a tuple carries fewer letters than `d` times its coordinates. -/ theorem digit_bound {a n m k d : Nat} (ha : 0 < a) (hm : m < a ^ d) (h : a ^ n ≤ m ^ (k + 1)) : n < d * (k + 1) := FRC.Logic.digit_bound ha hm h /-- `f 0 || … || f (n − 1)`. -/ @[reducible] def anyBelow (f : Nat → Bool) : Nat → Bool := FRC.Logic.anyBelow f theorem anyBelow_congr {f g : Nat → Bool} : ∀ {n : Nat}, (∀ x, x < n → f x = g x) → anyBelow f n = anyBelow g n := FRC.Logic.anyBelow_congr theorem anyBelow_false : ∀ n, anyBelow (fun _ => false) n = false := FRC.Logic.anyBelow_false theorem allBelow_const (b : Bool) : ∀ n, 0 < n → allBelow (fun _ => b) n = b := FRC.Logic.allBelow_const b theorem anyBelow_and_const (c : Bool) (F : Nat → Bool) (n : Nat) : anyBelow (fun x => c && F x) n = (c && anyBelow F n) := FRC.Logic.anyBelow_and_const c F n theorem allBelow_and_const (c : Bool) (F : Nat → Bool) (n : Nat) (hn : 0 < n) : allBelow (fun y => c && F y) n = (c && allBelow F n) := FRC.Logic.allBelow_and_const c F n hn /-- Among the `x < n`, the clause `x = y` picks `y`: `∃ x < n, (c ∧ x = y ∧ F x)` is `c ∧ F y` for `y < n`. -/ theorem anyBelow_pick (c : Bool) (F : Nat → Bool) (y : Nat) : ∀ n, anyBelow (fun x => (c && decide (x = y)) && F x) n = (if y < n then c && F y else false) := FRC.Logic.anyBelow_pick c F y end aliases -- Ledger predicates of 25-godel (generated by make_predicates.py from docs/25-godel/25-godel-ledger.json; edit the ledger, not this section) /-- 25:C1 (p25010) — No finite structure interprets $\mathsf{Q}$: a model of $\mathsf{Q}$ has an injective successor with $0$ outside its range, and on a finite set an injective map is onto. -/ theorem p25010 : (∀ (n : Nat) (S : Nat → Nat), (∀ (x : Nat), x < n → S x < n) → (∀ (x y : Nat), x < n → y < n → S x = S y → x = y) → ∀ (z : Nat), z < n → ∃ x, x < n ∧ S x = z) ∧ ∀ (n : Nat) (S : Nat → Nat), (∀ (x : Nat), x < n → S x < n) → (∀ (x y : Nat), x < n → y < n → S x = S y → x = y) → ∀ (z : Nat), z < n → ¬∀ (x : Nat), x < n → S x ≠ z := @FRC.Ledger.p25010 /-- 25:C5 (p25014) — Tarski scoped: the $m+1$ sentences $\varphi,\neg\varphi,\dots,\neg^{m}\varphi$ outnumber the $m$ elements of $\M$, so every numbering of the sentences by elements of $\M$ gives two of them the same number. Truth in $\M$ is defined externally by a finite table with the evaluation procedure of C2. What fails is the internalisation of truth. -/ theorem p25014 : ∀ (m : Nat) (g : Nat → Nat), (∀ (i : Nat), i < m + (1 : Nat) → g i < m) → ¬∀ (i j : Nat), i < m + (1 : Nat) → j < m + (1 : Nat) → g i = g j → i = j := @FRC.Ledger.p25014 /-- 25:D1 (p25015) — Relational diagonal: an agent of storage capacity $K$ with $a^{K}0$ constant. -/ theorem p25019 : (∀ (p : Nat), (0 : Nat) < p → ∀ (t : FRC.Godel.Tm), FRC.Godel.val ((1 : Nat) % p) (fun x y => (x + y) % p) t = FRC.Godel.leaves t % p) ∧ ∀ (p : Nat), (0 : Nat) < p → ∀ (s t : FRC.Godel.Tm), FRC.Godel.leaves s = FRC.Godel.leaves t → FRC.Godel.val ((1 : Nat) % p) (fun x y => (x + y) % p) s = FRC.Godel.val ((1 : Nat) % p) (fun x y => (x + y) % p) t := And.intro @FRC.Godel.value_leaves (@FRC.Godel.equal_leaves_equal_value) /-- 25:E2 (p25020) — Vanishing reach: an agent of capacity $(K,H)$ certifies at most $a^{B+1}$ sentences over all its runs, the records being strings of length at most $B$. The certified fraction of the truths of length at most $L$ (E1) is at most $a^{B+1}/2^{\alpha L}$, below $1/N$ for every $N$ once $L$ is large enough. -/ theorem p25020 : (∀ (a : Nat), (2 : Nat) ≤ a → ∀ (B : Nat), FRC.Logic.records a B < a ^ (B + (1 : Nat))) ∧ ∀ (a : Nat), (2 : Nat) ≤ a → ∀ (B N L : Nat), a ^ (B + (1 : Nat)) * N ≤ L → FRC.Logic.records a B * N < (2 : Nat) ^ L := And.intro @FRC.Godel.records_lt (@FRC.Godel.reach_vanishes) /-- 25:F1 (p25023) — Mention cost: if the truth of a formula in $\M$ depends on coordinate $i$ of a tuple of variables, then $v_{i}$ occurs in it. A formula whose truth depends on all $N$ coordinates has length at least $N$. A quantifier block binding an $N$-tuple contributes at least $N$ symbols. -/ theorem p25023 : (∀ (p : Nat) (φ : FRC.Godel.Fm) {env env' : Nat → Nat}, (∀ (i : Nat), FRC.Godel.occ i φ = true → env i = env' i) → FRC.Godel.holds p env φ = FRC.Godel.holds p env' φ) ∧ (∀ (p : Nat) (φ : FRC.Godel.Fm) (env : Nat → Nat) (i v : Nat), FRC.Godel.holds p (FRC.Godel.upd env i v) φ ≠ FRC.Godel.holds p env φ → FRC.Godel.occ i φ = true) ∧ (∀ (φ : FRC.Godel.Fm) (N : Nat), (∀ (i : Nat), i < N → FRC.Godel.occ i φ = true) → N ≤ FRC.Godel.size φ) ∧ (∀ (p : Nat) (φ : FRC.Godel.Fm) (N : Nat), (∀ (i : Nat), i < N → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env i v) φ ≠ FRC.Godel.holds p env φ) → N ≤ FRC.Godel.size φ) ∧ ∀ (n : Nat) (φ : FRC.Godel.Fm), FRC.Godel.size (FRC.Godel.exBlock n φ) = FRC.Godel.size φ + (3 : Nat) * n := And.intro @FRC.Godel.holds_congr (And.intro @FRC.Godel.mention (And.intro @FRC.Godel.arity_le_size (And.intro @FRC.Godel.mention_cost (@FRC.Godel.size_exBlock)))) /-- 25:F2 (p25024) — No compression: code strings of length at most $N$ as tuples in $\M^{N}$, one coordinate per symbol, signature and alphabet fixed independently of $N$, $\theta$ non-degenerate. The G\"odel template has no instance at any scale. The diagonal formula needs $\lvert \delta\rvert\ge3N+\lvert \theta\rvert>N$ symbols, so its code is not in $\M^{N}$. Splitting the scales fails: $\delta$ outgrows the scale $\theta$ reads. -/ theorem p25024 : (∀ (p N : Nat) (diag θ : FRC.Godel.Fm), (∀ (i : Nat), i < (2 : Nat) * N → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env i v) diag ≠ FRC.Godel.holds p env diag) → (2 : Nat) * N + FRC.Godel.size θ + (3 : Nat) * N ≤ FRC.Godel.size (FRC.Godel.exBlock N (diag.conj θ))) ∧ (∀ (N : Nat), (1 : Nat) ≤ N → ∀ (φ : FRC.Godel.Fm), ¬FRC.Godel.size (FRC.Godel.exBlock N φ) ≤ N) ∧ (∀ (p N N₂ : Nat) (diag θ : FRC.Godel.Fm), (∀ (i : Nat), i < N₂ → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env i v) θ ≠ FRC.Godel.holds p env θ) → N₂ < FRC.Godel.size (FRC.Godel.exBlock N (diag.conj θ))) ∧ ∀ (p : Nat) (φ : FRC.Godel.Fm) (N : Nat), (∀ (i : Nat), i < N → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env i v) φ ≠ FRC.Godel.holds p env φ) → N ≤ FRC.Godel.size φ := And.intro @FRC.Godel.template_size (And.intro @FRC.Godel.no_template (And.intro @FRC.Godel.split_scale (@FRC.Godel.mention_cost))) /-- 25:F3 (p25025) — Quotation exceeds mention: a formula's arity is below its length. No sentence $\lambda$ contains a subformula whose truth depends on all coordinates of a tuple of arity at least $\lvert \lambda\rvert$. Under any coding that spends at least $\lvert \lambda\rvert$ coordinates on $\lambda$, per-symbol coding included, no sentence's truth is sensitive to every coordinate of its own code. -/ theorem p25025 : (∀ (φ : FRC.Godel.Fm) (j N : Nat), (∀ (i : Nat), i < N → FRC.Godel.occ (i + j) φ = true) → N < FRC.Godel.size φ) ∧ (∀ (p : Nat) (φ : FRC.Godel.Fm) (j N : Nat), (∀ (i : Nat), i < N → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env (i + j) v) φ ≠ FRC.Godel.holds p env φ) → N < FRC.Godel.size φ) ∧ ∀ (p : Nat) {ψ lam : FRC.Godel.Fm}, FRC.Godel.Subformula ψ lam → ∀ (j N : Nat), FRC.Godel.size lam ≤ N → ¬∀ (i : Nat), i < N → ∃ env v, FRC.Godel.holds p (FRC.Godel.upd env (i + j) v) ψ ≠ FRC.Godel.holds p env ψ := And.intro @FRC.Godel.arity_lt_size (And.intro @FRC.Godel.mention_cost_lt (@FRC.Godel.no_self_reading)) /-- 25:F4 (p25048) — Density: $m$ has $d$ base-$a$ digits. An injective coding of length-$n$ strings by $k$-tuples, $k\ge1$, needs $m^{k}\ge a^{n}$, so $n