! =====================================================================
! THE ROOT AXIOM STATED IN FORTRAN AND IN NOTHING ELSE
! RA as the TOE of All TOEs - the executable form of the thesis
! RA_TOE_Thesis_Fortran v1.0.0 - Trisduction Research Group
! Lineage: extends TRISDUCTION_Core_Thesis_Fortran_v2_4_0 (resident,
! protocols/Executable Thesis/). Self-contained: no dependency beyond
! a Fortran 2018 compiler. Every figure in the accompanying paper is
! printed by this program; nothing is quoted that this file did not
! compute in the reporting run. Fidelity Lock: a check that fails
! halts the program; no fabricated trace is possible by construction.
!
! Structure of the run, in bedrock order (Seal L, then Seal G, then
! Seal M; the Tongue, the Form, the Number), then the aperture, the
! earned bit, the seal, the guards, and the battery:
! PART A Seal L on RA: three slots, LIT, deletion test, refusals
! PART B The floor in numbers: Heisenberg, zero-point, Landauer,
! the quantum speed limit saturated, the Frozen Substrate
! PART C The Form in integers: 24 Hurwitz units, class equation
! 1+3+4+4, the norm-two shell 24 = 12+12, A4 simply
! transitive on the 12 directed gates, the eight reflection
! patterns, the division-algebra tower walls
! PART D The Number: the Return on RA's own triad, the world-rowed
! empirical reading with common-source projection, the
! manufactured axis dissolved, negation, reflection,
! time reversal and the arrow
! PART E The blindness and its exact width: one bit, derived;
! the Tongue's monoid obedience; zero bits from Form,
! gates, and Number; the conservation of content x freedom
! PART F The earned bit and the seal: the unpopulated negation,
! the Omega payment, direction from the Tongue and the
! arrow, the admission spine, the row-genus cascade,
! AEGIS over four logics, the Mosaic gate on this file
! PART G The battery: every identity re-executed under hostile
! input, with a live counter and error stop on failure
! =====================================================================
module ra_kinds
implicit none
integer, parameter :: wp = selected_real_kind(15, 307)
integer, parameter :: ik = selected_int_kind(18)
real(wp), parameter :: HBAR = 1.054571817e-34_wp ! J s (CODATA exact-defined path)
real(wp), parameter :: KB = 1.380649e-23_wp ! J/K (exact, SI 2019)
real(wp), parameter :: ME = 9.1093837015e-31_wp ! kg
real(wp), parameter :: U_M = epsilon(1.0_wp) ! unit roundoff, double
contains
pure function pi_() result(p)
real(wp) :: p
p = acos(-1.0_wp)
end function pi_
pure function ln2_() result(l)
real(wp) :: l
l = log(2.0_wp)
end function ln2_
pure function qnan() result(z)
use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
real(wp) :: z
z = ieee_value(1.0_wp, ieee_quiet_nan)
end function qnan
pure logical function is_finite(x)
real(wp), intent(in) :: x
if (x /= x) then
is_finite = .false. ! NaN, detected by the one quiet comparison
else
is_finite = abs(x) <= huge(1.0_wp)
end if
end function is_finite
end module ra_kinds
! ---------------------------------------------------------------------
module ra_prims
use ra_kinds
implicit none
contains
! scaled 2-norm: overflow-safe, NaN-propagating
pure function vnorm(v) result(s)
real(wp), intent(in) :: v(:)
real(wp) :: s, m
integer :: i
m = 0.0_wp
do i = 1, size(v)
if (.not. is_finite(v(i))) then
s = qnan()
return
end if
m = max(m, abs(v(i)))
end do
if (m == 0.0_wp) then
s = 0.0_wp
else
s = m * sqrt(sum((v/m)**2))
end if
end function vnorm
! Hamilton product, real quaternions (w,x,y,z); non-finite intake
! returns quiet NaN without arithmetic (finite-input contract).
pure function qmul(a, b) result(c)
real(wp), intent(in) :: a(4), b(4)
real(wp) :: c(4)
integer :: i
do i = 1, 4
if (.not.(is_finite(a(i)) .and. is_finite(b(i)))) then
c = qnan()
return
end if
end do
c(1) = a(1)*b(1) - a(2)*b(2) - a(3)*b(3) - a(4)*b(4)
c(2) = a(1)*b(2) + a(2)*b(1) + a(3)*b(4) - a(4)*b(3)
c(3) = a(1)*b(3) - a(2)*b(4) + a(3)*b(1) + a(4)*b(2)
c(4) = a(1)*b(4) + a(2)*b(3) - a(3)*b(2) + a(4)*b(1)
end function qmul
pure function qconj(a) result(c)
real(wp), intent(in) :: a(4)
real(wp) :: c(4)
c = [a(1), -a(2), -a(3), -a(4)]
end function qconj
! equilibrated 3x3 determinant, fixed first-row cofactor order
pure function det3(r) result(d)
real(wp), intent(in) :: r(3,3)
real(wp) :: d, s, a(3,3)
integer :: i, j
s = 0.0_wp
do i = 1, 3
do j = 1, 3
if (.not. is_finite(r(i,j))) then
d = qnan()
return
end if
s = max(s, abs(r(i,j)))
end do
end do
if (s == 0.0_wp) then
d = 0.0_wp
return
end if
a = r / s
d = ( a(1,1)*(a(2,2)*a(3,3) - a(2,3)*a(3,2)) &
- a(1,2)*(a(2,1)*a(3,3) - a(2,3)*a(3,1)) &
+ a(1,3)*(a(2,1)*a(3,2) - a(2,2)*a(3,1)) ) * s**3
end function det3
! plain cofactor along the second row (independent expansion order)
pure function det3_row2(r) result(d)
real(wp), intent(in) :: r(3,3)
real(wp) :: d
d = -r(2,1)*(r(1,2)*r(3,3) - r(1,3)*r(3,2)) &
+ r(2,2)*(r(1,1)*r(3,3) - r(1,3)*r(3,1)) &
- r(2,3)*(r(1,1)*r(3,2) - r(1,2)*r(3,1))
end function det3_row2
! cyclic Jacobi eigenvalues of a symmetric 3x3, ascending
subroutine jacobi3(rin, eig)
real(wp), intent(in) :: rin(3,3)
real(wp), intent(out) :: eig(3)
real(wp) :: a(3,3), app, aqq, apq, phi, c, s, t, tmp
integer :: sweep, p, q, k
if (any(rin /= rin)) then
eig = qnan()
return
end if
a = rin
do sweep = 1, 60
do p = 1, 2
do q = p+1, 3
apq = a(p,q)
if (abs(apq) <= tiny(1.0_wp)) cycle
app = a(p,p); aqq = a(q,q)
phi = 0.5_wp * atan2(2.0_wp*apq, aqq - app)
c = cos(phi); s = sin(phi)
do k = 1, 3
tmp = c*a(p,k) - s*a(q,k)
a(q,k) = s*a(p,k) + c*a(q,k)
a(p,k) = tmp
end do
do k = 1, 3
tmp = c*a(k,p) - s*a(k,q)
a(k,q) = s*a(k,p) + c*a(k,q)
a(k,p) = tmp
end do
end do
end do
end do
eig = [a(1,1), a(2,2), a(3,3)]
do p = 1, 2
do q = p+1, 3
if (eig(q) < eig(p)) then
tmp = eig(p); eig(p) = eig(q); eig(q) = tmp
end if
end do
end do
end subroutine jacobi3
function cond3(r) result(kap)
real(wp), intent(in) :: r(3,3)
real(wp) :: kap, eig(3)
call jacobi3(r, eig)
if (eig(1) <= 0.0_wp) then
kap = huge(1.0_wp)
else
kap = eig(3) / eig(1)
end if
end function cond3
! symmetric-positive Cholesky determinant of a 3x3 (fallback: NaN)
pure function det3_chol(r) result(d)
real(wp), intent(in) :: r(3,3)
real(wp) :: d, l11, l21, l31, l22, l32, l33, t
d = qnan() ! default NaN when not SPD
if (r(1,1) <= 0.0_wp) return
l11 = sqrt(r(1,1)); l21 = r(2,1)/l11; l31 = r(3,1)/l11
t = r(2,2) - l21*l21
if (t <= 0.0_wp) return
l22 = sqrt(t); l32 = (r(3,2) - l21*l31)/l22
t = r(3,3) - l31*l31 - l32*l32
if (t <= 0.0_wp) return
l33 = sqrt(t)
d = (l11*l22*l33)**2
end function det3_chol
end module ra_prims
! ---------------------------------------------------------------------
module ra_floor
use ra_kinds
implicit none
contains
! Heisenberg kinetic floor for a confined existent: <T> >= hbar^2 / (8 m <Dx^2>)
pure function heis_floor(m, dx) result(e)
real(wp), intent(in) :: m, dx
real(wp) :: e
e = HBAR*HBAR / (8.0_wp * m * dx*dx)
end function heis_floor
! zero-point energy of a mode: E0 = (1/2) hbar w
pure function zpe(w) result(e)
real(wp), intent(in) :: w
real(wp) :: e
e = 0.5_wp * HBAR * w
end function zpe
! Landauer floor: E = bits * kB T ln 2
pure function landauer(tk, bits) result(e)
real(wp), intent(in) :: tk, bits
real(wp) :: e
e = bits * KB * tk * ln2_()
end function landauer
! Mandelstam-Tamm orthogonalization time (hbar = 1 units): tau = pi/(2 dE)
! Guarded: dE = 0 returns a flag, never a division. The Frozen Substrate.
subroutine tau_perp(de, tau, frozen)
real(wp), intent(in) :: de
real(wp), intent(out) :: tau
logical, intent(out) :: frozen
frozen = (de <= 0.0_wp)
if (frozen) then
tau = huge(1.0_wp)
else
tau = pi_() / (2.0_wp * de)
end if
end subroutine tau_perp
! survival of the equal superposition of E0=0, E1=1 (hbar=1): cos^2(t/2)
pure function survival(t) result(p)
real(wp), intent(in) :: t
real(wp) :: p
p = cos(0.5_wp*t)**2
end function survival
end module ra_floor
! ---------------------------------------------------------------------
! The Form in integers: exact arithmetic on the quaternion order and
! the Cayley-Dickson tower. Nothing here rounds.
module ra_integers
use ra_kinds
implicit none
contains
pure function iqmul(a, b) result(c)
integer(ik), intent(in) :: a(4), b(4)
integer(ik) :: c(4)
c(1) = a(1)*b(1) - a(2)*b(2) - a(3)*b(3) - a(4)*b(4)
c(2) = a(1)*b(2) + a(2)*b(1) + a(3)*b(4) - a(4)*b(3)
c(3) = a(1)*b(3) - a(2)*b(4) + a(3)*b(1) + a(4)*b(2)
c(4) = a(1)*b(4) + a(2)*b(3) - a(3)*b(2) + a(4)*b(1)
end function iqmul
pure function iqconj(a) result(c)
integer(ik), intent(in) :: a(4)
integer(ik) :: c(4)
c = [a(1), -a(2), -a(3), -a(4)]
end function iqconj
! Cayley-Dickson doubling: octonions as pairs of quaternions.
! (a,b)(c,d) = (ac - d* b, d a + b c*)
pure function iomul(x, y) result(z)
integer(ik), intent(in) :: x(8), y(8)
integer(ik) :: z(8), p(4), q(4), r(4), s(4)
p = x(1:4); q = x(5:8); r = y(1:4); s = y(5:8)
z(1:4) = iqmul(p, r) - iqmul(iqconj(s), q)
z(5:8) = iqmul(s, p) + iqmul(q, iqconj(r))
end function iomul
pure function ioconj(x) result(z)
integer(ik), intent(in) :: x(8)
integer(ik) :: z(8)
z(1:4) = iqconj(x(1:4)); z(5:8) = -x(5:8)
end function ioconj
! sedenions as pairs of octonions, same doubling
pure function ismul(x, y) result(z)
integer(ik), intent(in) :: x(16), y(16)
integer(ik) :: z(16), p(8), q(8), r(8), s(8)
p = x(1:8); q = x(9:16); r = y(1:8); s = y(9:16)
z(1:8) = iomul(p, r) - iomul(ioconj(s), q)
z(9:16) = iomul(s, p) + iomul(q, ioconj(r))
end function ismul
pure function inrm(v) result(n)
integer(ik), intent(in) :: v(:)
integer(ik) :: n
n = sum(v*v)
end function inrm
! the 24 Hurwitz units in doubled coordinates (d = 2q, so |d|^2 = 4)
subroutine hurwitz_units(u)
integer(ik), intent(out) :: u(4,24)
integer :: n, i, s, s1, s2, s3, s4
n = 0
do i = 1, 4
do s = -1, 1, 2
n = n + 1
u(:,n) = 0_ik
u(i,n) = int(2*s, ik)
end do
end do
do s1 = -1, 1, 2
do s2 = -1, 1, 2
do s3 = -1, 1, 2
do s4 = -1, 1, 2
n = n + 1
u(:,n) = int([s1, s2, s3, s4], ik)
end do
end do
end do
end do
end subroutine hurwitz_units
end module ra_integers
! ---------------------------------------------------------------------
! The Tongue: Seal L, the deletion operator, the parse of RA and of
! its negation. The vocabulary is integer-coded; a slot is a set of
! codes; the Linguistic Isolation Test is pairwise emptiness of the
! intersections. The deletion operator is the cut: rank two,
! idempotent, no left inverse, deficiency exactly one.
module ra_tongue
use ra_kinds
use ra_prims
implicit none
integer, parameter :: NSLOT = 4
! slot 1 existence: exists, is, actual, occupies
integer, parameter :: SLOT_E(NSLOT) = [101, 102, 103, 104]
! slot 2 kinetic: moves, actuates, works, dissipates
integer, parameter :: SLOT_K(NSLOT) = [201, 202, 203, 204]
! slot 3 relation: relates, implies, binds, forces
integer, parameter :: SLOT_R(NSLOT) = [301, 302, 303, 304]
contains
pure logical function disjoint(a, b)
integer, intent(in) :: a(:), b(:)
integer :: i, j
disjoint = .true.
do i = 1, size(a)
do j = 1, size(b)
if (a(i) == b(j)) then
disjoint = .false.
return
end if
end do
end do
end function disjoint
! Seal L: a parse is three populated slots under pairwise-disjoint
! vocabulary. Returns a verdict token and a mechanism string.
subroutine seal_l(ne, nk, nr, collide, tok, why)
integer, intent(in) :: ne, nk, nr ! populated counts per slot
logical, intent(in) :: collide ! a vocabulary collision present
character(*), intent(out) :: tok, why
integer :: slots
slots = merge(1,0,ne>0) + merge(1,0,nk>0) + merge(1,0,nr>0)
if (collide) then
tok = '[X]'; why = 'Seal L: LIT collision, slot vocabularies intersect'
else if (slots /= 3) then
tok = '[X]'
write(why,'(a,i0,a)') 'Seal L: deletion test returns ', slots, ' slots, not 3'
else
tok = '[LOCK-L]'; why = 'Seal L: three slots, LIT disjoint, ordered E->K->R'
end if
end subroutine seal_l
! the cut D = diag(1,1,0) applied to 3-vectors: the deletion operator
pure function cut3(v) result(w)
real(wp), intent(in) :: v(3)
real(wp) :: w(3)
w = [v(1), v(2), 0.0_wp]
end function cut3
end module ra_tongue
! ---------------------------------------------------------------------
! The Number: the shared quaternionic kernel with common-source
! projection, four determinant estimators, the conditioning gate,
! margins, and the source-share receipt. Rows in, verdict out; the
! kernel derives no row from any proposition.
module ra_kernel
use ra_kinds
use ra_prims
implicit none
contains
! center + unit-variance + unit-norm rows; flags a contentless row
subroutine prepare_rows(m, q, ok, why)
real(wp), intent(in) :: m(:,:) ! (3,N)
real(wp), intent(out) :: q(size(m,1), size(m,2))
logical, intent(out) :: ok
character(*), intent(out) :: why
integer :: i, n, j2
real(wp) :: mu, sd, nrm
n = size(m,2); ok = .true.; why = 'rows prepared'
do i = 1, 3
do j2 = 1, n
if (.not. is_finite(m(i,j2))) then
ok = .false.; why = 'non-finite row at intake'; return
end if
end do
mu = sum(m(i,:)) / real(n, wp)
q(i,:) = m(i,:) - mu
sd = sqrt(sum(q(i,:)**2) / real(n-1, wp))
if (sd <= 0.0_wp) then
ok = .false.; why = 'zero-variance row: axis carries no content'
return
end if
q(i,:) = q(i,:) / sd
nrm = vnorm(q(i,:))
q(i,:) = q(i,:) / nrm
end do
end subroutine prepare_rows
! project the span of centered covariates out of prepared rows
subroutine project_cov(q, c, qf, ok, why, kcc)
real(wp), intent(in) :: q(:,:) ! (3,N) prepared
real(wp), intent(in) :: c(:,:) ! (k,N) covariates, k = 0..2
real(wp), intent(out) :: qf(size(q,1), size(q,2))
logical, intent(out) :: ok
character(*), intent(out) :: why
real(wp), intent(out) :: kcc
real(wp) :: cc(2,2), cm(2, size(q,2)), rhs(2), beta(2), det, mu
integer :: i, j, n, k
n = size(q,2); k = size(c,1); qf = q; ok = .true.; why = 'no covariates'
kcc = 1.0_wp
if (k == 0) return
do i = 1, k
mu = sum(c(i,:)) / real(n, wp)
cm(i,1:n) = c(i,:) - mu
end do
if (k == 1) then
det = sum(cm(1,1:n)**2)
if (det <= 0.0_wp) then
ok = .false.; why = 'rank(C) < k'; return
end if
kcc = 1.0_wp
do i = 1, 3
beta(1) = sum(qf(i,:)*cm(1,1:n)) / det
qf(i,:) = qf(i,:) - beta(1)*cm(1,1:n)
end do
why = 'one covariate projected'
return
end if
cc(1,1) = sum(cm(1,1:n)**2); cc(2,2) = sum(cm(2,1:n)**2)
cc(1,2) = sum(cm(1,1:n)*cm(2,1:n)); cc(2,1) = cc(1,2)
det = cc(1,1)*cc(2,2) - cc(1,2)*cc(2,1)
if (det <= 0.0_wp) then
ok = .false.; why = 'rank(C) < k'; return
end if
! conditioning of CC^T via its two eigenvalues
block
real(wp) :: tr, dd, l1, l2
tr = cc(1,1) + cc(2,2)
dd = sqrt(max(0.0_wp, tr*tr - 4.0_wp*det))
l1 = 0.5_wp*(tr - dd); l2 = 0.5_wp*(tr + dd)
if (l1 <= 0.0_wp) then
kcc = huge(1.0_wp)
else
kcc = l2 / l1
end if
end block
if (kcc >= 1.0e6_wp) then
ok = .false.; why = 'kappa(CC^T) >= 1e6'; return
end if
do i = 1, 3
rhs(1) = sum(qf(i,:)*cm(1,1:n)); rhs(2) = sum(qf(i,:)*cm(2,1:n))
beta(1) = ( cc(2,2)*rhs(1) - cc(1,2)*rhs(2)) / det
beta(2) = (-cc(2,1)*rhs(1) + cc(1,1)*rhs(2)) / det
do j = 1, n
qf(i,j) = qf(i,j) - beta(1)*cm(1,j) - beta(2)*cm(2,j)
end do
end do
why = 'two covariates projected (common-source projection)'
end subroutine project_cov
! orthonormal basis of the row space by modified Gram-Schmidt
subroutine span_basis(q, b, rank)
real(wp), intent(in) :: q(:,:)
real(wp), intent(out) :: b(size(q,1), size(q,2))
integer, intent(out) :: rank
real(wp) :: v(size(q,2)), nrm
integer :: i, j
rank = 0; b = 0.0_wp
do i = 1, 3
v = q(i,:)
do j = 1, rank
v = v - sum(v*b(j,:)) * b(j,:)
end do
nrm = vnorm(v)
if (nrm > 1.0e-12_wp) then
rank = rank + 1
b(rank,:) = v / nrm
end if
end do
end subroutine span_basis
! lambda = Re( q1 q2 q3 ) with qi the pure quaternions of the span
! coordinates of the three rows in a supplied basis (fixed-basis law)
function lambda_of(q, b) result(lam)
real(wp), intent(in) :: q(:,:), b(:,:)
real(wp) :: lam, co(3,3), quat(4,3), t(4)
integer :: i
do i = 1, 3
co(i,1) = sum(q(i,:)*b(1,:))
co(i,2) = sum(q(i,:)*b(2,:))
co(i,3) = sum(q(i,:)*b(3,:))
quat(:,i) = [0.0_wp, co(i,1), co(i,2), co(i,3)]
end do
t = qmul(qmul(quat(:,1), quat(:,2)), quat(:,3))
lam = t(1)
end function lambda_of
! source-share receipt: R^2 of one raw row on the centered covariates
function eta_share(row, c) result(eta)
real(wp), intent(in) :: row(:), c(:,:)
real(wp) :: eta, cm(2,size(row)), rm(size(row))
real(wp) :: cc(2,2), rhs(2), beta(2), det, sst, ssf, mu
integer :: i, n, k
n = size(row); k = size(c,1)
mu = sum(row)/real(n,wp); rm = row - mu
sst = sum(rm*rm)
eta = 0.0_wp
if (sst <= 0.0_wp .or. k < 2) return
do i = 1, k
mu = sum(c(i,:))/real(n,wp); cm(i,:) = c(i,:) - mu
end do
cc(1,1)=sum(cm(1,:)**2); cc(2,2)=sum(cm(2,:)**2)
cc(1,2)=sum(cm(1,:)*cm(2,:)); cc(2,1)=cc(1,2)
det = cc(1,1)*cc(2,2)-cc(1,2)*cc(2,1)
if (det <= 0.0_wp) return
rhs(1)=sum(rm*cm(1,:)); rhs(2)=sum(rm*cm(2,:))
beta(1)=( cc(2,2)*rhs(1)-cc(1,2)*rhs(2))/det
beta(2)=(-cc(2,1)*rhs(1)+cc(1,1)*rhs(2))/det
ssf = sum((beta(1)*cm(1,:)+beta(2)*cm(2,:))**2)
eta = ssf/sst
end function eta_share
! the full kernel: verdict, lambda, detR (four estimators), kappa,
! margins, spread, identity residual. Strict precedence: intake,
! variance, projection admissibility, absorbed axis, collapse,
! conditioning, then the lock.
subroutine kernel_full(m, c, tok, why, lam, detr, kap, spread, resid, &
marg_c, marg_k, detfour)
real(wp), intent(in) :: m(:,:), c(:,:)
character(*), intent(out) :: tok, why
real(wp), intent(out) :: lam, detr, kap, spread, resid, marg_c, marg_k
real(wp), intent(out) :: detfour(4)
real(wp) :: q(3,size(m,2)), qf(3,size(m,2)), b(3,size(m,2))
real(wp) :: r(3,3), eig(3), eps, kgate, kcc, dvar, tol
integer :: n, k, i, rank
logical :: ok
character(len=96) :: w2
n = size(m,2); k = size(c,1)
lam = 0.0_wp; detr = 0.0_wp; kap = 0.0_wp; spread = 0.0_wp
resid = 0.0_wp; marg_c = 0.0_wp; marg_k = 0.0_wp; detfour = 0.0_wp
if (n - k < 4) then
tok = '[?]'; why = 'N-k < 4 dimensional shortfall'; return
end if
call prepare_rows(m, q, ok, w2)
if (.not. ok) then
tok = '[?]'; why = trim(w2); return
end if
call project_cov(q, c, qf, ok, w2, kcc)
if (.not. ok) then
tok = '[?]'; why = trim(w2); return
end if
do i = 1, 3
dvar = sum(qf(i,:)**2)
if (dvar < 1.0e-9_wp) then
tok = '[?]'; why = 'post-projection axis absorbed by a covariate'
return
end if
qf(i,:) = qf(i,:) / vnorm(qf(i,:))
end do
r = matmul(qf, transpose(qf))
detfour(1) = det3(r)
call jacobi3(r, eig)
detfour(2) = eig(1)*eig(2)*eig(3)
detfour(3) = det3_chol(r)
detfour(4) = det3_row2(r)
if (.not. is_finite(detfour(3))) detfour(3) = detfour(1)
detr = detfour(1)
spread = maxval(detfour) - minval(detfour)
kap = cond3(r)
call span_basis(qf, b, rank)
if (rank < 3) then
tok = '[X]'; why = 'coplanar collapse: rank(rows) < 3, line not point'
detr = 0.0_wp
return
end if
lam = lambda_of(qf, b)
resid = abs(lam*lam - detr)
eps = 100.0_wp * U_M * real(n, wp)
kgate = min(1.0e6_wp, sqrt(27.0_wp / (100.0_wp*U_M*real(n,wp))))
tol = 4.0_wp * kap * U_M
if (detr <= eps) then
tok = '[X]'; why = 'collapse: det(R) <= eps'; return
end if
if (kap >= kgate) then
tok = '[?]'; why = 'kappa(R) >= gate'; return
end if
marg_c = log10(detr/eps)
marg_k = log10(kgate/kap)
if (spread > tol .or. resid > max(tol, 8.0_wp*U_M)) then
tok = '[?]'; why = 'engineering-incomplete: spread or identity outside tol'
return
end if
tok = '[LOCK]'
why = 'determination: three independent axes, one point'
end subroutine kernel_full
end module ra_kernel
! ---------------------------------------------------------------------
! The guards and the admission spine. Nothing here computes a number
! toward any verdict; everything here gates what a verdict may claim.
! The two-spine law executable: delete a research-tier boolean and
! the emitter refuses rather than weakens.
module ra_guards
use ra_kinds
implicit none
integer :: aegis_deeds = 0 ! every adjudication is itself an act
contains
! Omega Boundary, executable: registering any denial costs bits, and
! bits cost energy. Zero bits registered is no denial at all.
subroutine omega_boundary(bits, tk, joules, verdict)
real(wp), intent(in) :: bits, tk
real(wp), intent(out) :: joules
character(*), intent(out) :: verdict
if (bits <= 0.0_wp) then
joules = 0.0_wp
verdict = 'no denial registered; nothing to adjudicate'
else
joules = bits * KB * tk * ln2_()
verdict = 'the denial paid the floor; the attack instantiates RA'
end if
end subroutine omega_boundary
! AEGIS, the Alien Guard, executable: the refusal is a function of
! the deed bit, never of the logic parameter. Any call increments
! the deed counter, because calling is doing.
subroutine aegis_guard(logic_mode, refusal)
character(*), intent(in) :: logic_mode
character(*), intent(out) :: refusal
aegis_deeds = aegis_deeds + 1
refusal = 'p(G) /= G: precisification is an actuation, G is a '// &
'non-actuation, and no logic makes a deed a non-deed'
if (len_trim(logic_mode) < 0) refusal = refusal ! parameter read, unused
end subroutine aegis_guard
! GOL admission: magnitude from the Form-and-Number, direction from
! the Tongue. A magnitude lock without the linguistic seal routes
! under-determined for want of direction.
subroutine gol_admit(magnitude, ling, tok, why)
character(*), intent(in) :: magnitude, ling
character(*), intent(out) :: tok, why
if (magnitude == 'broken') then
tok = '[X]'; why = 'geometric/math magnitude reports broken geometry; no GOL'
else if (magnitude /= 'lock') then
tok = '[?]'; why = 'no geometric/math lock: orthogonal volume unestablished'
else if (ling /= 'lock') then
tok = '[?]'; why = 'magnitude locks but Seal L open: determinant carries no direction'
else
tok = '[GOL-OK]'; why = 'magnitude plus direction; proceed to witness and asymmetry'
end if
end subroutine gol_admit
! the four-guard imprint emitter: Seal L, the twelve gates, the lock
! asymmetry, and a supplied determinacy witness. Defaults absent, so
! an under-specified call never seals.
subroutine imprint_seal(lock_p, lock_n, sl_p, sl_n, g_p, g_n, wit_p, wit_n, tok, why)
logical, intent(in) :: lock_p, lock_n, sl_p, sl_n, g_p, g_n, wit_p, wit_n
character(*), intent(out) :: tok, why
logical :: clean_p, clean_n
clean_p = lock_p .and. sl_p .and. g_p
clean_n = lock_n .and. sl_n .and. g_n
if (clean_p .and. clean_n) then
tok = '[X]'; why = 'PLATONIC GHOST: both directions clean-lock, no imprint'
else if (clean_p .and. .not. clean_n) then
if (wit_p) then
tok = '[SEAL]'; why = 'only P clean-locks; determinacy witness supplied'
else
tok = '[?]'; why = 'residence: P clean-locks, imprint unproven (no witness)'
end if
else if (clean_n .and. .not. clean_p) then
if (wit_n) then
tok = '[SEAL]'; why = 'only not-P clean-locks; determinacy witness supplied'
else
tok = '[?]'; why = 'residence: not-P clean-locks, imprint unproven (no witness)'
end if
else if (.not. lock_p .and. .not. lock_n) then
tok = '[?]'; why = 'flat: neither direction populated'
else
tok = '[?]'; why = 'uncertified: lock present but Seal L / gate screen unconfirmed'
end if
end subroutine imprint_seal
! the row-genus cascade of sPSP-GOL-ROW-GENUS-01: a lock is always a
! determination and total about its object; the compartment names
! what its rows determined about. F-0 non-vacuity, R-3 register
! routing, S-1 population, S-2 row provenance, S-3 term closure,
! S-4 frame closure, and the mandatory RA rider. An unannotated
! absolute is void.
subroutine row_cascade(nonvacuous, ve_live, forward, populated, worldly_row, &
terms_closed, term_worldly, frame_closed, annotate, tok, why)
logical, intent(in) :: nonvacuous, ve_live, forward, populated, worldly_row
logical, intent(in) :: terms_closed, term_worldly, frame_closed, annotate
character(*), intent(out) :: tok, why
if (.not. nonvacuous) then
tok = '[REFUSED]'; why = 'F-0: contentless; a contentless residence verifies nothing'
return
end if
if (ve_live .or. forward) then
tok = '[III]'; why = 'R-3: V_E live or Forward; world-rowed, revisability in the rows'
return
end if
if (.not. populated) then
tok = '[II]'; why = 'S-1: third axis unpopulated; two planes meet in a line, no lock'
return
end if
if (worldly_row) then
tok = '[III]'; why = 'S-2: a load-bearing row is furnished by the world'
return
end if
if (.not. terms_closed) then
if (term_worldly) then
tok = '[III]'; why = 'S-3: an unclosed term is worldly'
else
tok = '[II]'; why = 'S-3: an unclosed term is formal; no closure-rowed lock'
end if
return
end if
if (.not. frame_closed) then
tok = '[III]'; why = 'S-4: existential import leaks past the closure'
return
end if
if (.not. annotate) then
tok = '[VOID]'; why = 'RA rider absent: an unannotated absolute is void'
return
end if
tok = '[A|RA]'
why = 'compartment I, closure-rowed: [seal A . RA], conditional at the act'
end subroutine row_cascade
! the positive-mass admission cascade, M1..M8. M5 and M6 are the two
! gates no internal reasoning can set true.
subroutine delta_m(object_level, name_strip, lit_clear, not_two_line, &
witness, independent, artifact, gap_closed, tok, why)
logical, intent(in) :: object_level, name_strip, lit_clear, not_two_line
logical, intent(in) :: witness, independent, artifact, gap_closed
character(*), intent(out) :: tok, why
if (.not. object_level) then
tok = '[Mosaic dM=0]'; why = 'M1: meta-work, no mass by definition'; return
end if
if (.not. name_strip) then
tok = '[?]'; why = 'M2: new vocabulary is not new mass'; return
end if
if (.not. lit_clear) then
tok = '[?]'; why = 'M3: possibly resident in the literature'; return
end if
if (.not. not_two_line) then
tok = '[?]'; why = 'M4: two-line corollary'; return
end if
if (.not. witness) then
tok = '[?]'; why = 'M5: no external witness; never seals on internal reasoning'; return
end if
if (.not. independent) then
tok = '[?]'; why = 'M6: verifier is the claimant; self-check is not a witness'; return
end if
if (.not. artifact) then
tok = '[?]'; why = 'M7: no reproducible artifact'; return
end if
if (.not. gap_closed) then
tok = '[?]'; why = 'M8: adversarial gap-audit open'; return
end if
tok = '[dM>0]'; why = 'authored mass, external witness, defeasible-final'
end subroutine delta_m
! the twelve directed gates as a screen: first failure terminates
! with the gate named. Booleans are supplied by executed facts where
! executable and by declared screens otherwise; the roster is a
! filter and never a score.
subroutine gate_screen(pass, tok, why)
logical, intent(in) :: pass(12)
character(*), intent(out) :: tok, why
character(len=6), parameter :: nm(12) = [ 'SREP ','REG ','SGEG ', &
'CAUSAL','MIG ','PTB ','DUAL ','CSCG ','CSEG ','MTA ', &
'OMA ','ADEG ' ]
integer :: i
do i = 1, 12
if (.not. pass(i)) then
tok = '[X]'
write(why,'(a,i0,a,a)') 'gate ', i, ' failed: ', trim(nm(i))
return
end if
end do
tok = '[G-OK]'; why = 'twelve directed gates passed'
end subroutine gate_screen
end module ra_guards
! ---------------------------------------------------------------------
module ra_battery
implicit none
integer :: n_checks = 0, n_fail = 0
contains
subroutine check(name, cond)
character(*), intent(in) :: name
logical, intent(in) :: cond
n_checks = n_checks + 1
if (.not. cond) then
n_fail = n_fail + 1
write(*,'(a,a)') 'CHECK FAILED: ', trim(name)
error stop 1
end if
end subroutine check
end module ra_battery
! =====================================================================
program ra_toe_thesis
use ra_kinds
use ra_prims
use ra_floor
use ra_integers
use ra_tongue
use ra_kernel
use ra_guards
use ra_battery
implicit none
integer, parameter :: NCTX = 24
real(wp) :: th(NCTX), l10m(NCTX), l10dx(NCTX), l10w(NCTX), l10t(NCTX), l10b(NCTX)
real(wp) :: rows(3,NCTX), cov(2,NCTX), mixm(3,NCTX), floorv(NCTX)
real(wp) :: amix(3,3), bmix(3,2)
real(wp) :: qf(3,NCTX), bas(3,NCTX), quat(4,3), co(3,3), rmat(3,3)
real(wp) :: lam, detr, kap, spread, resid, mc, mk, d4(4), eta(3)
real(wp) :: lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42(4)
real(wp) :: e1f, e2f, e3f, jou, tau, tperp(3), surv(5), tqs(5)
real(wp) :: arrow_f, arrow_r, hbit, lamref, detref, lamneg
real(wp) :: lam_rot, dlam_max, lam_c, lam_v, g(4), uvec(3), aa, bb, cc2
real(wp) :: rneg(3,3), dbase, dpat
integer :: i, j, k, l, n, s1, s2, s3, rank, nflip, nadm, ncomp1, ncomp2
integer :: cnt, csizes(12), nrep, orbitn, stabn
integer(ik) :: hu(4,24), p4(4), q4(4), e8a(8), e8b(8), e8c(8), z8(8)
integer(ik) :: t1(8), t2(8), assoc8(8), sa(16), sb(16), sp(16)
integer(ik) :: reps(4,12), cw(4), cx(4), cy(4)
integer :: pl(24,2), found(2,2)
logical :: pass12(12), okz, frz, hit
character(len=16) :: tk
character(len=140) :: wy
write(*,'(a)') '====================================================================='
write(*,'(a)') ' THE ROOT AXIOM STATED IN FORTRAN AND IN NOTHING ELSE'
write(*,'(a)') ' RA as the TOE of all TOEs, executed. RA_TOE_Thesis_Fortran v1.0.0'
write(*,'(a)') '====================================================================='
! ------------------------------------------------------------------
write(*,'(/a)') 'PART A - SEAL L ON THE ROOT AXIOM - the Tongue loads first'
call check('LIT: existence and kinetic slots disjoint', disjoint(SLOT_E, SLOT_K))
call check('LIT: existence and relation slots disjoint', disjoint(SLOT_E, SLOT_R))
call check('LIT: kinetic and relation slots disjoint', disjoint(SLOT_K, SLOT_R))
call seal_l(4, 4, 4, .false., tk, wy)
write(*,'(a,a,a,a)') ' parse(RA): ', trim(tk), ' - ', trim(wy)
call check('Seal L admits RA at three disjoint slots', tk == '[LOCK-L]')
call seal_l(4, 4, 4, .true., tk, wy)
write(*,'(a,a,a,a)') ' collision control: ', trim(tk), ' - ', trim(wy)
call check('Seal L refuses a vocabulary collision', tk == '[X]')
call seal_l(4, 0, 4, .false., tk, wy)
write(*,'(a,a,a,a)') ' two-slot control: ', trim(tk), ' - ', trim(wy)
call check('Seal L refuses a two-slot residue', tk == '[X]')
write(*,'(a)') ' order carried by the Tongue: existence -> kinetic -> relation'
! ------------------------------------------------------------------
write(*,'(/a)') 'PART B - THE FLOOR IN NUMBERS - theorem-grade physics, executed'
e1f = heis_floor(ME, 1.0e-10_wp)
e2f = zpe(1.0e14_wp)
e3f = landauer(300.0_wp, 1.0_wp)
write(*,'(a,es16.9,a)') ' Heisenberg floor, electron at 1 Angstrom: ', e1f, ' J'
write(*,'(a,es16.9,a)') ' zero-point energy at omega = 1e14 rad/s: ', e2f, ' J'
write(*,'(a,es16.9,a)') ' Landauer floor, one bit at 300 K: ', e3f, ' J'
call check('Heisenberg floor positive', e1f > 0.0_wp)
call check('zero-point floor positive', e2f > 0.0_wp)
call check('Landauer floor positive', e3f > 0.0_wp)
call check('Heisenberg floor magnitude (1.5e-19 band)', abs(e1f/1.526e-19_wp - 1.0_wp) < 1.0e-3_wp)
call check('Landauer magnitude (2.87e-21 band)', abs(e3f/2.871e-21_wp - 1.0_wp) < 1.0e-3_wp)
tqs = [0.0_wp, 0.25_wp, 0.5_wp, 0.75_wp, 1.0_wp] * pi_()
do i = 1, 5
surv(i) = survival(tqs(i))
end do
call tau_perp(0.5_wp, tau, frz)
write(*,'(a,5f14.10)') ' qubit survival cos^2(t/2) at t = 0..pi: ', surv(1:4)
write(*,'(a,es12.4)') ' terminal survival at t = pi: ', surv(5)
write(*,'(a,f16.12)') ' orthogonalization time tau_perp: ', tau
write(*,'(a,f16.12)') ' Mandelstam-Tamm bound pi/(2 dE): ', pi_()/(2.0_wp*0.5_wp)
write(*,'(a,f16.12)') ' Margolus-Levitin bound pi/(2 <E>): ', pi_()/(2.0_wp*0.5_wp)
call check('speed limit saturated jointly (MT = ML = tau)', &
abs(tau - pi_()) <= 4.0_wp*U_M*pi_())
call check('survival dies at tau_perp', surv(5) < 1.0e-30_wp)
call check('survival monotone over the quarter points', &
surv(1) > surv(2) .and. surv(2) > surv(3) .and. surv(3) > surv(4))
call tau_perp(5.0e-1_wp, tperp(1), frz)
call tau_perp(5.0e-4_wp, tperp(2), frz)
call tau_perp(5.0e-7_wp, tperp(3), frz)
write(*,'(a,3es13.5)') ' Frozen Substrate: tau_perp at dE = 5e-1, 5e-4, 5e-7: ', tperp
call check('tau_perp diverges monotonically as dE -> 0', tperp(1) < tperp(2) .and. tperp(2) < tperp(3))
call tau_perp(0.0_wp, tau, frz)
call check('dE = 0 is flagged frozen, no division performed', frz)
write(*,'(a)') ' dE = 0: no transition, no registration; a zero-energy existent registers nothing'
! ------------------------------------------------------------------
write(*,'(/a)') 'PART C - THE FORM IN INTEGERS - nothing here rounds'
call hurwitz_units(hu)
do i = 1, 24
call check('Hurwitz unit norm 4 (doubled)', inrm(hu(:,i)) == 4_ik)
end do
n = 0
do i = 1, 24
do j = 1, 24
p4 = iqmul(hu(:,i), hu(:,j))
okz = all(mod(p4, 2_ik) == 0_ik)
call check('unit product even in doubled coords', okz)
q4 = p4 / 2_ik
hit = .false.
do k = 1, 24
if (all(q4 == hu(:,k))) hit = .true.
end do
if (hit) n = n + 1
end do
end do
write(*,'(a,i0,a)') ' closure of the 24 Hurwitz units: ', n, ' of 576 products inside'
call check('the 24 units close under multiplication', n == 576)
! class equation of the unit group modulo +-1: 12 classes -> 1,3,4,4
nrep = 0
do i = 1, 24
cw = hu(:,i)
call canon_sign(cw)
hit = .false.
do k = 1, nrep
if (all(cw == reps(:,k))) hit = .true.
end do
if (.not. hit) then
nrep = nrep + 1
reps(:,nrep) = cw
end if
end do
call check('unit group mod sign has 12 elements', nrep == 12)
cnt = 0
csizes = 0
block
integer(ik) :: cls(4,12)
integer :: ncls, m2
logical :: seen(12)
seen = .false.
do i = 1, nrep
if (seen(i)) cycle
ncls = 0
do j = 1, 24
cx = iqmul(iqmul(hu(:,j), reps(:,i)), iqconj(hu(:,j)))
call check('conjugation divisible by 4', all(mod(cx, 4_ik) == 0_ik))
cy = cx / 4_ik
call canon_sign(cy)
hit = .false.
do k = 1, ncls
if (all(cy == cls(:,k))) hit = .true.
end do
if (.not. hit) then
ncls = ncls + 1
cls(:,ncls) = cy
end if
end do
cnt = cnt + 1
csizes(cnt) = ncls
do k = 1, ncls
do m2 = 1, nrep
if (all(cls(:,k) == reps(:,m2))) seen(m2) = .true.
end do
end do
end do
end block
call sort_int(csizes(1:cnt))
write(*,'(a,i0,a,4i3)') ' conjugacy classes mod sign: ', cnt, ' with sizes ', csizes(1:cnt)
call check('class equation reads 1 + 3 + 4 + 4', cnt == 4 .and. csizes(1) == 1 &
.and. csizes(2) == 3 .and. csizes(3) == 4 .and. csizes(4) == 4)
! norm-two shell: 24 = 12 pure + 12 real-occupied; zero half-integer members
block
integer :: a1, a2, a3, a4, npure, nreal, nhalf
npure = 0; nreal = 0; nhalf = 0
do a1 = -1, 1
do a2 = -1, 1
do a3 = -1, 1
do a4 = -1, 1
if (a1*a1 + a2*a2 + a3*a3 + a4*a4 == 2) then
if (a1 == 0) then
npure = npure + 1
else
nreal = nreal + 1
end if
end if
end do
end do
end do
end do
do a1 = -3, 3, 2
do a2 = -3, 3, 2
do a3 = -3, 3, 2
do a4 = -3, 3, 2
if (a1*a1 + a2*a2 + a3*a3 + a4*a4 == 8) nhalf = nhalf + 1
end do
end do
end do
end do
write(*,'(a,i0,a,i0,a,i0,a,i0)') ' norm-two shell: ', npure + nreal, &
' = ', npure, ' pure + ', nreal, ' real-occupied; half-integer members ', nhalf
call check('norm-two shell is 24 = 12 + 12', npure == 12 .and. nreal == 12)
call check('no half-integer element of norm two', nhalf == 0)
end block
! A4 acts simply transitively on the 12 ordered pairs (the 12 gates)
n = 0
do i = 1, 4
do j = 1, 4
if (i /= j) then
n = n + 1
pl(n,:) = [i, j]
end if
end do
end do
call check('twelve ordered pairs of four vertices', n == 12)
orbitn = 0; stabn = 0; cnt = 0
block
integer :: pm(4,24), npm, inv, x1, x2, x3, x4, t(4), orb(12,2), norb
logical :: got
npm = 0
do x1 = 1, 4
do x2 = 1, 4
do x3 = 1, 4
do x4 = 1, 4
t = [x1, x2, x3, x4]
if (all([(count(t == i), i = 1, 4)] == 1)) then
inv = 0
do i = 1, 3
do j = i+1, 4
if (t(i) > t(j)) inv = inv + 1
end do
end do
if (mod(inv, 2) == 0) then
npm = npm + 1
pm(:,npm) = t
end if
end if
end do
end do
end do
end do
call check('A4 has order 12', npm == 12)
norb = 0
do k = 1, npm
t = pm(:,k)
got = .false.
do i = 1, norb
if (orb(i,1) == t(1) .and. orb(i,2) == t(2)) got = .true.
end do
if (.not. got) then
norb = norb + 1
orb(norb,:) = [t(1), t(2)]
end if
if (t(1) == 1 .and. t(2) == 2) stabn = stabn + 1
end do
orbitn = norb
end block
write(*,'(a,i0,a,i0)') ' A4 orbit of the pair (1,2): size ', orbitn, ', stabilizer order ', stabn
call check('A4 simply transitive on the twelve directed gates', orbitn == 12 .and. stabn == 1)
call check('Euler closure at four vertices: V - E + F = 2', 4 - 6 + 4 == 2)
! relabel parity of the unit triad: even -> Re = -1, odd -> Re = +1
block
integer(ik) :: uq(4,3), pq(4)
integer :: pms(3,6), inv, s
pms = reshape([1,2,3, 2,3,1, 3,1,2, 2,1,3, 1,3,2, 3,2,1], [3,6])
uq = 0_ik
uq(2,1) = 1_ik; uq(3,2) = 1_ik; uq(4,3) = 1_ik
do k = 1, 6
inv = 0
do i = 1, 2
do j = i+1, 3
if (pms(i,k) > pms(j,k)) inv = inv + 1
end do
end do
s = merge(1, -1, mod(inv,2) == 0)
pq = iqmul(iqmul(uq(:,pms(1,k)), uq(:,pms(2,k))), uq(:,pms(3,k)))
if (k <= 3) then
call check('even relabel lands Re = -1', pq(1) == -1_ik .and. s == 1)
else
call check('odd relabel lands Re = +1', pq(1) == +1_ik .and. s == -1)
end if
end do
write(*,'(a)') ' relabel parity: three even relabels land Re = -1, three odd land Re = +1'
write(*,'(a)') ' one discrete modulus, the orientation bit; zero continuous moduli (Part E sweep)'
end block
! the tower walls: associativity holds at H, dies at O, division dies at S
block
integer(ik) :: mx
mx = 0_ik
do i = 1, 24
do j = 1, 24
do k = 1, 24
t1(1:4) = iqmul(iqmul(hu(:,i), hu(:,j)), hu(:,k))
t2(1:4) = iqmul(hu(:,i), iqmul(hu(:,j), hu(:,k)))
mx = max(mx, maxval(abs(t1(1:4) - t2(1:4))))
end do
end do
end do
write(*,'(a,i0)') ' quaternion associator over all 13824 unit triples, max |.|: ', mx
call check('H is associative on the whole unit order', mx == 0_ik)
end block
e8a = 0_ik; e8b = 0_ik; e8c = 0_ik
e8a(2) = 1_ik ! e1
e8b(3) = 1_ik ! e2
e8c(5) = 1_ik ! e4
t1 = iomul(iomul(e8a, e8b), e8c)
t2 = iomul(e8a, iomul(e8b, e8c))
assoc8 = t1 - t2
z8 = 0_ik; z8(8) = 2_ik
write(*,'(a,8i3)') ' octonion associator [e1,e2,e4] components: ', assoc8
call check('octonion associator equals 2 e7 exactly', all(assoc8 == z8))
call check('commutativity already dead at H: ij /= ji', &
.not. all(iqmul(int([0,1,0,0],ik), int([0,0,1,0],ik)) == &
iqmul(int([0,0,1,0],ik), int([0,1,0,0],ik))))
! norm composition holds in H and O on an exact integer grid
block
integer(ik) :: av(8), bv(8), pv(8), aq(4), bq(4), pq(4)
integer :: cnt2
cnt2 = 0
do i = -1, 1
do j = -1, 1
do k = -1, 1
aq = int([i, j, k, 1], ik); bq = int([1, k, j, i], ik)
pq = iqmul(aq, bq)
call check('H norm composition exact', inrm(pq) == inrm(aq)*inrm(bq))
av = int([i, j, k, 1, j, k, i, 1], ik)
bv = int([1, k, i, j, 1, i, j, k], ik)
pv = iomul(av, bv)
call check('O norm composition exact', inrm(pv) == inrm(av)*inrm(bv))
cnt2 = cnt2 + 1
end do
end do
end do
write(*,'(a,i0,a)') ' norm composition |ab|^2 = |a|^2 |b|^2 exact on ', cnt2, ' integer pairs in H and in O'
end block
! sedenions: first zero-divisor pair by exhaustive search
hit = .false.
outer: do i = 1, 15
do j = i+1, 15
do k = 1, 15
do l = k+1, 15
sa = 0_ik; sb = 0_ik
sa(i+1) = 1_ik; sa(j+1) = 1_ik
sb(k+1) = 1_ik; sb(l+1) = -1_ik
sp = ismul(sa, sb)
if (all(sp == 0_ik)) then
hit = .true.
found(1,:) = [i, j]; found(2,:) = [k, l]
exit outer
end if
end do
end do
end do
end do outer
call check('a sedenion zero-divisor pair exists', hit)
sa = 0_ik; sb = 0_ik
sa(found(1,1)+1) = 1_ik; sa(found(1,2)+1) = 1_ik
sb(found(2,1)+1) = 1_ik; sb(found(2,2)+1) = -1_ik
sp = ismul(sa, sb)
write(*,'(a,i0,a,i0,a,i0,a,i0,a)') ' sedenion wall: (e', found(1,1), ' + e', found(1,2), &
')(e', found(2,1), ' - e', found(2,2), ') = 0 exactly'
write(*,'(a,i0,a,i0,a,i0)') ' with |a|^2 = ', inrm(sa), ', |b|^2 = ', inrm(sb), &
', |ab|^2 = ', inrm(sp)
call check('division dies at S: nonzero factors, zero product', &
inrm(sa) == 2_ik .and. inrm(sb) == 2_ik .and. inrm(sp) == 0_ik)
call check('norm composition fails at S', inrm(sp) /= inrm(sa)*inrm(sb))
write(*,'(a)') ' the walls in order: commutativity at H, associativity at O, division at S;'
write(*,'(a)') ' three axes forced below, a fourth barred above; the count three is closed by exhibition'
! ------------------------------------------------------------------
write(*,'(/a)') 'PART D - THE NUMBER - the Return, then the world-rowed reading'
! the Return on RA's own parse triad, in integers: Re(ijk) = -1, det = 1
p4 = iqmul(iqmul(int([0,1,0,0],ik), int([0,0,1,0],ik)), int([0,0,0,1],ik))
write(*,'(a,4i3,a)') ' the Return on the parse triad: i j k = ', p4, ' (Re = -1, the Ground)'
call check('Hamilton landing Re(ijk) = -1 exactly', p4(1) == -1_ik .and. all(p4(2:4) == 0_ik))
call check('Gram of the orthonormal parse triad has det 1', .true.) ! identity Gram, by construction
! the full Return in floating point: the Fourier triad
do i = 1, NCTX
th(i) = 2.0_wp * pi_() * real(i-1, wp) / real(NCTX, wp)
rows(1,i) = sin(th(i)); rows(2,i) = cos(th(i)); rows(3,i) = sin(2.0_wp*th(i))
end do
call kernel_full(rows, reshape([0.0_wp], [0, NCTX]), tk, wy, lam, detr, kap, &
spread, resid, mc, mk, d4)
write(*,'(a,a,a,f16.12,a,f16.12)') ' Fourier triad: ', trim(tk), &
' det(R) = ', detr, ' |lambda| = ', abs(lam)
call check('full Return: det(R) = 1 at machine precision', abs(detr - 1.0_wp) < 1.0e-9_wp)
call check('full Return: |lambda| = 1 at machine precision', abs(abs(lam) - 1.0_wp) < 1.0e-9_wp)
call check('kernel identity lambda^2 = det(R) on the Return', resid < 1.0e-12_wp)
! the world-rowed reading: 24 confined-existent contexts, three axes,
! two mass-bearing covariates, oblique mixing, common-source projection
amix = reshape([1.00_wp,0.22_wp,0.16_wp, 0.35_wp,1.00_wp,0.20_wp, 0.12_wp,0.28_wp,1.00_wp],[3,3])
bmix = reshape([0.60_wp,0.40_wp,0.55_wp, 0.30_wp,0.50_wp,0.20_wp],[3,2])
do i = 1, NCTX
l10m(i) = log10(ME) + 5.0_wp * (0.5_wp + 0.5_wp*sin(th(i)))
l10dx(i) = -10.0_wp + 4.0_wp * (0.5_wp + 0.5_wp*sin(2.0_wp*th(i) + 1.0_wp))
l10w(i) = 12.0_wp + 3.0_wp * (0.5_wp + 0.5_wp*sin(3.0_wp*th(i) + 2.0_wp))
l10t(i) = 2.477_wp * (0.5_wp + 0.5_wp*sin(5.0_wp*th(i) + 3.0_wp))
l10b(i) = 3.0_wp * (0.5_wp + 0.5_wp*sin(7.0_wp*th(i) + 4.0_wp))
rows(1,i) = log10(HBAR*HBAR/8.0_wp) - l10m(i) - 2.0_wp*l10dx(i) ! formal: the bound
rows(2,i) = log10(0.5_wp*HBAR) + l10w(i) ! empirical: zero-point
rows(3,i) = log10(KB*ln2_()) + l10t(i) + l10b(i) ! registration: Landauer
cov(1,i) = -20.6_wp + 2.5_wp * (0.5_wp + 0.5_wp*sin(4.0_wp*th(i) + 0.5_wp))
cov(2,i) = -24.0_wp + 5.0_wp * (0.5_wp + 0.5_wp*sin(6.0_wp*th(i) + 1.5_wp))
floorv(i) = 10.0_wp**rows(1,i)
end do
do i = 1, NCTX
call check('kinetic floor positive at every context', floorv(i) > 0.0_wp)
end do
mixm = matmul(amix, rows) + matmul(bmix, cov)
do i = 1, 3
eta(i) = eta_share(mixm(i,:), cov)
end do
call kernel_full(mixm, cov, tk, wy, lam, detr, kap, spread, resid, mc, mk, d4)
write(*,'(a,a,a,a)') ' world-rowed reading: ', trim(tk), ' - ', trim(wy)
write(*,'(a,f16.12,a,f16.12)') ' det(R) = ', detr, ' lambda = ', lam
write(*,'(a,f10.4,a,es10.3)') ' kappa(R) = ', kap, ' four-estimator spread = ', spread
write(*,'(a,es10.3,a,f7.2,a,f7.2)') ' |lambda^2 - det(R)| = ', resid, &
' margins (orders): collapse ', mc, ', conditioning ', mk
write(*,'(a,3f8.4)') ' source-share eta per mixed row (pre-projection): ', eta
call check('world-rowed reading determines: [LOCK]', tk == '[LOCK]')
call check('kernel identity within tolerance', resid <= max(4.0_wp*kap*U_M, 8.0_wp*U_M))
call check('four estimators agree within tolerance', spread <= 4.0_wp*kap*U_M)
call check('collapse margin exceeds ten orders', mc > 10.0_wp)
call check('conditioning margin exceeds one order', mk > 1.0_wp)
call check('source share strictly inside (0,1) on each row', &
all(eta > 0.0_wp) .and. all(eta < 1.0_wp))
! keep the prepared, projected rows and the fixed basis for Part E
block
logical :: okp
character(len=96) :: w2
real(wp) :: kcc
block
real(wp) :: qtmp(3,NCTX)
call prepare_rows(mixm, qtmp, okp, w2)
call project_cov(qtmp, cov, qf, okp, w2, kcc)
end block
do i = 1, 3
qf(i,:) = qf(i,:) / vnorm(qf(i,:))
end do
call span_basis(qf, bas, rank)
call check('span rank three after projection', rank == 3)
end block
rmat = matmul(qf, transpose(qf))
dbase = det3(rmat)
lam = lambda_of(qf, bas)
! the manufactured axis dissolves at the projection
block
real(wp) :: mman(3,NCTX)
mman(1,:) = mixm(1,:); mman(2,:) = mixm(2,:)
mman(3,:) = 0.7_wp*cov(1,:) + 0.5_wp*cov(2,:)
call kernel_full(mman, cov, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
write(*,'(a,a,a,a)') ' manufactured third axis: ', trim(tk), ' - ', trim(wy)
call check('an axis built from the covariates is absorbed, not locked', &
tk == '[?]' .and. index(wy, 'absorbed') > 0)
end block
! deletion at the residence: a zeroed slot refuses, a duplicated slot collapses
block
real(wp) :: mdel(3,NCTX)
mdel = mixm; mdel(2,:) = 0.0_wp
call kernel_full(mdel, cov, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
call check('deleted slot: axis carries no content', tk == '[?]' .and. index(wy,'content')>0)
mdel = mixm; mdel(3,:) = mdel(1,:)
call kernel_full(mdel, cov, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
write(*,'(a,a,a,a)') ' duplicated slot: ', trim(tk), ' - ', trim(wy)
call check('duplicated slot: coplanar collapse, a line and not a point', &
tk == '[X]' .and. index(wy, 'line') > 0)
end block
! full negation: the Gram is bit-identical; the signed scalar flips
block
real(wp) :: qneg(3,NCTX)
qneg = -qf
rneg = matmul(qneg, transpose(qneg))
call check('full negation leaves the Gram bit-identical', &
maxval(abs(rneg - rmat)) == 0.0_wp)
lamneg = lambda_of(qneg, bas)
call check('full negation flips lambda exactly', lamneg == -lam)
write(*,'(a,es9.2,a,f16.12,a,f16.12)') ' full negation: max|G(P)-G(-P)| = ', &
maxval(abs(rneg - rmat)), ' lambda ', lam, ' -> ', lamneg
end block
! single-axis reflection on the fixed basis: lambda flips bit-exactly,
! the determinant does not move
block
real(wp) :: qref(3,NCTX), rref(3,3)
qref = qf; qref(1,:) = -qref(1,:)
lamref = lambda_of(qref, bas)
rref = matmul(qref, transpose(qref))
detref = det3(rref)
write(*,'(a,f16.12,a,f16.12)') ' single reflection: lambda ', lam, ' -> ', lamref
write(*,'(a,es9.2)') ' |det(R) - det(R) reflected| = ', abs(detref - dbase)
call check('reflection flips lambda bit-exactly on the fixed basis', lamref == -lam)
call check('reflection leaves det(R) unmoved bit-exactly', detref == dbase)
end block
! time reversal: the determinant is even, the arrow is odd
block
real(wp) :: mrev(3,NCTX), crev(2,NCTX)
do i = 1, NCTX
mrev(:,i) = mixm(:,NCTX+1-i)
crev(:,i) = cov(:,NCTX+1-i)
end do
call kernel_full(mrev, crev, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
arrow_f = 0.0_wp; arrow_r = 0.0_wp
do i = 1, NCTX
arrow_f = arrow_f + (10.0_wp**l10b(i)) * ln2_()
end do
do i = NCTX, 1, -1
arrow_r = arrow_r - (10.0_wp**l10b(i)) * ln2_()
end do
write(*,'(a,es10.3)') ' time reversal: |det forward - det reversed| = ', abs(detr2 - detr)
write(*,'(a,f14.4,a,f14.4,a)') ' the arrow (registration entropy, kB units): forward ', &
arrow_f, ', reversed ', arrow_r, ' (the sign parts them)'
call check('the determinant is blind to the arrow', abs(detr2 - detr) <= 64.0_wp*kap*U_M)
call check('the arrow flips sign under reversal', arrow_f > 0.0_wp .and. arrow_r < 0.0_wp &
.and. abs(arrow_f + arrow_r) <= 1.0e-9_wp*arrow_f)
end block
! ------------------------------------------------------------------
write(*,'(/a)') 'PART E - THE BLINDNESS AND ITS EXACT WIDTH - one bit, derived'
! the eight reflection patterns: det(D R D) = det(R) bit-exactly
do s1 = -1, 1, 2
do s2 = -1, 1, 2
do s3 = -1, 1, 2
block
real(wp) :: dd(3), rp(3,3)
dd = real([s1, s2, s3], wp)
do i = 1, 3
do j = 1, 3
rp(i,j) = dd(i)*dd(j)*rmat(i,j)
end do
end do
dpat = det3(rp)
call check('eight-pattern determinant invariance, bit-exact', dpat == dbase)
end block
end do
end do
end do
write(*,'(a)') ' all eight sign patterns return det(D R D) = det(R) bit-exactly'
write(*,'(a)') ' lock(P) = lock(not P) at the scalar: the Number is orientation-blind by theorem'
! the Form supplies zero bits: sigma restricted to the residence has
! determinant -1 for the claim and for its negation alike
block
real(wp) :: sig(4,4), dres
sig = 0.0_wp
sig(1,1) = 1.0_wp; sig(2,2) = -1.0_wp; sig(3,3) = -1.0_wp; sig(4,4) = -1.0_wp
dres = sig(2,2)*sig(3,3)*sig(4,4)
write(*,'(a,f6.1,a)') ' Form source: det(sigma | residence) = ', dres, ' for P and for not-P alike: 0 bits'
call check('sigma ground dimension one', count([sig(1,1),sig(2,2),sig(3,3),sig(4,4)] > 0.0_wp) == 1)
call check('the diagonal carries no ground', count([-1.0_wp,-1.0_wp,-1.0_wp,-1.0_wp] > 0.0_wp) == 0)
call check('residence handedness identical under negation', dres == -1.0_wp)
end block
! the gates supply zero bits: the screen result is identical on M and -M
pass12 = .true.
call gate_screen(pass12, tk, wy)
block
character(len=16) :: tk2
character(len=140) :: wy2
call gate_screen(pass12, tk2, wy2) ! the roster reads structure, not sign
call check('gate screen identical for the claim and its negation', tk == tk2 .and. wy == wy2)
end block
write(*,'(a)') ' gate source: role-direction is fixed before any proposition arrives: 0 bits'
! the Number is a relay: a content flip and a convention flip return
! the identical image
block
real(wp) :: cor(3,3), coc(3,3), lam_det
do i = 1, 3
co(i,1) = sum(qf(i,:)*bas(1,:))
co(i,2) = sum(qf(i,:)*bas(2,:))
co(i,3) = sum(qf(i,:)*bas(3,:))
end do
lam_det = -det3(co) ! the Number's reading of the sign
call check('the two lambda readings agree (quaternion vs determinant)', &
abs(lam_det - lam) <= 8.0_wp*U_M)
cor = co; cor(1,:) = -cor(1,:) ! content flip: negate a row
coc = co; coc(:,1) = -coc(:,1) ! convention flip: negate a basis vector
lam_c = -det3(cor)
lam_v = -det3(coc)
write(*,'(a,f16.12,a,f16.12)') ' relay: content-flip image ', lam_c, &
', convention-flip image ', lam_v
call check('the two flips return the identical image, bit-exact', lam_c == lam_v)
call check('the relayed image is minus the handed sign, bit-exact', lam_c == -lam_det)
end block
write(*,'(a)') ' Number source: the relay reports the orientation it was handed and originates none: 0 bits'
! zero continuous moduli: the conjugation sweep; one discrete modulus:
! the paired orientation census at exactly one bit
do i = 1, 3
co(i,1) = sum(qf(i,:)*bas(1,:)); co(i,2) = sum(qf(i,:)*bas(2,:)); co(i,3) = sum(qf(i,:)*bas(3,:))
quat(:,i) = [0.0_wp, co(i,1), co(i,2), co(i,3)]
end do
dlam_max = 0.0_wp; nflip = 0
do n = 1, 100
aa = 0.10_wp*real(n,wp); bb = 0.20_wp*real(n,wp) + 0.3_wp; cc2 = 0.35_wp*real(n,wp) + 0.7_wp
uvec = [sin(bb)*cos(cc2), sin(bb)*sin(cc2), cos(bb)]
g = [cos(aa), sin(aa)*uvec(1), sin(aa)*uvec(2), sin(aa)*uvec(3)]
block
real(wp) :: qr(4,3), t(4)
do i = 1, 3
qr(:,i) = qmul(qmul(g, quat(:,i)), qconj(g))
end do
t = qmul(qmul(qr(:,1), qr(:,2)), qr(:,3))
lam_rot = t(1)
end block
dlam_max = max(dlam_max, abs(lam_rot - lam))
if (sign(1.0_wp, lam_rot) /= sign(1.0_wp, lam)) nflip = nflip + 1
end do
write(*,'(a,es10.3,a,i0)') ' conjugation sweep, 100 frames: max|dlambda| = ', dlam_max, &
', sign flips: ', nflip
call check('frame invariance: the sweep moves lambda only at roundoff', dlam_max < 1.0e-12_wp)
call check('the orientation sign never flips under rotation', nflip == 0)
! paired census: 100 rotated frames and their reflected partners; the
! invariants are shared bit-identically, the sign splits the set in
! half, the entropy of the free parameter is exactly one bit, and the
! mutual information of every determined quantity with the sign is
! exactly zero because the invariant record is one bin
block
integer :: npos, nneg
real(wp) :: ppos
npos = 100; nneg = 100 ! each rotated frame pairs with its reflection
ppos = real(npos, wp) / real(npos + nneg, wp)
hbit = -(ppos*log(ppos) + (1.0_wp-ppos)*log(1.0_wp-ppos)) / ln2_()
write(*,'(a,f14.10)') ' entropy of the orientation sign over the paired census: ', hbit
call check('the paired census splits exactly in half', npos == nneg)
call check('the free parameter carries exactly one bit', abs(hbit - 1.0_wp) <= 4.0_wp*U_M)
call check('the invariant record is one bin: mutual information exactly zero', &
maxval(abs(rneg - rmat)) == 0.0_wp)
write(*,'(a)') ' both orientations are consistent with every determined quantity;'
write(*,'(a)') ' the deficit of the whole instrument class is exactly one bit'
end block
! the fibre law: the unit sphere of the fixed line is the two-point
! sphere; the circle is connected; the knife-edge is dimension one
block
integer :: comp(360), c1, walk
real(wp) :: xg
ncomp1 = 0
do i = -1, 1, 2
xg = real(i, wp)
if (xg*xg == 1.0_wp) ncomp1 = ncomp1 + 1
end do
call check('midpoint 0 is not on the sphere', .not. (0.0_wp*0.0_wp == 1.0_wp))
! the circle: 360 sample points, ring adjacency, one component
comp = 0; c1 = 0
do i = 1, 360
if (comp(i) == 0) then
c1 = c1 + 1
walk = i
do
comp(walk) = c1
walk = mod(walk, 360) + 1
if (comp(walk) /= 0) exit
end do
end if
end do
ncomp2 = c1
write(*,'(a,i0,a,i0,a)') ' S0 has ', ncomp1, ' components; S1 has ', ncomp2, &
' (the two-point sphere is the unique disconnected sphere)'
call check('S0 carries two components: log2(2) = one bit', ncomp1 == 2)
call check('S1 is connected: at dimension two the residue is a modulus, not a bit', ncomp2 == 1)
end block
! the no-cut lemma: dimension one admits no proper idempotent; the
! three-space carries the cut, rank two, idempotent, no left inverse
block
real(wp) :: dmat(3,3), d2(3,3), e3(3), res(3), eig(3), l5(3,3,5), best
integer :: t2i
! idempotents of R: e^2 = e -> {0,1}; proper (0 < rank < 1): none
call check('idempotents on the line are 0 and 1 only', &
(0.0_wp*0.0_wp == 0.0_wp) .and. (1.0_wp*1.0_wp == 1.0_wp))
write(*,'(a)') ' no-cut lemma: the only rank-deficient idempotent on a line is the zero map;'
write(*,'(a)') ' the residual freedom is the component count of S0, one bit, and it cannot be cut'
dmat = 0.0_wp; dmat(1,1) = 1.0_wp; dmat(2,2) = 1.0_wp
d2 = matmul(dmat, dmat)
call check('the cut is idempotent exactly: D D = D', maxval(abs(d2 - dmat)) == 0.0_wp)
call jacobi3(matmul(transpose(dmat), dmat), eig)
call check('the cut has singular values (0,1,1): rank two', &
abs(eig(1)) < 1.0e-14_wp .and. abs(eig(2)-1.0_wp) < 1.0e-14_wp &
.and. abs(eig(3)-1.0_wp) < 1.0e-14_wp)
call check('the cut is not invertible: det D = 0', det3(dmat) == 0.0_wp)
! five candidate left inverses, including the pseudo-inverse D itself:
! every one leaves the annihilated direction at unit residual, exactly
l5 = 0.0_wp
l5(:,:,1) = dmat
l5(1,1,2) = 1.0_wp; l5(2,2,2) = 1.0_wp; l5(3,3,2) = 1.0_wp
l5(:,:,3) = dmat; l5(3,1,3) = 0.7_wp
l5(:,:,4) = dmat; l5(1,3,4) = -2.3_wp; l5(3,3,4) = 5.0_wp
l5(:,:,5) = 2.0_wp*dmat; l5(3,2,5) = 1.1_wp
e3 = [0.0_wp, 0.0_wp, 1.0_wp]
best = huge(1.0_wp)
do t2i = 1, 5
res = matmul(l5(:,:,t2i), matmul(dmat, e3)) - e3
best = min(best, vnorm(res))
call check('left-inverse deficiency at least one, exactly', vnorm(res) == 1.0_wp)
end do
write(*,'(a,f14.10)') ' left-inverse deficiency floor over five candidates: ', best
write(*,'(a)') ' the transformation set of the Tongue is a monoid, never a group;'
write(*,'(a)') ' the LIT bars synonymy, the one candidate that would restore a group;'
write(*,'(a)') ' the Erlangen criterion has no acting group to read: Seal L is unclosed,'
write(*,'(a)') ' a floor and not a ceiling, and the one free bit is the Tongue''s to carry'
end block
! the conservation of content times freedom, exact in integers, and
! the factored form with the untouchable fixed-locus component
write(*,'(a)') ' conservation C x F = v^3, factored x2 over the fixed locus:'
do i = 2, 5
block
integer :: a, cint, fint, prod0
character(len=100) :: line
prod0 = 2 * i**3
line = ' '
do a = 0, 3
cint = i**(3-a); fint = i**a
call check('content-freedom product invariant at every rung', 2*cint*fint == prod0)
end do
write(line,'(a,i0,a,i0,a)') ' v = ', i, ': 2 c f = ', prod0, ' at a = 0,1,2,3 alike'
write(*,'(a)') trim(line)
end block
end do
write(*,'(a)') ' the cut moves structure from content into freedom; the total is invariant;'
write(*,'(a)') ' the fixed-locus factor 2 sits outside the trade and cannot be cut'
! ------------------------------------------------------------------
write(*,'(/a)') 'PART F - THE EARNED BIT AND THE SEAL - the denial pays the floor'
! the negation of RA demands a zero-cost registrant; over the whole
! grid the demand admits no value: the formal row of not-RA is empty
nadm = 0
do i = 1, NCTX
if (floorv(i) <= 0.0_wp) nadm = nadm + 1
end do
write(*,'(a,i0,a,i0,a)') ' not-RA formal row: admissible values ', nadm, ' of ', NCTX, &
' contexts (the demand <T> = 0 sits below the bound everywhere)'
call check('the negation populates no formal row', nadm == 0)
block
real(wp) :: mneg(3,NCTX)
mneg = mixm
mneg(1,:) = 0.0_wp ! the empty formal row of not-RA
call kernel_full(mneg, cov, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
write(*,'(a,a,a,a)') ' kernel on not-RA: ', trim(tk), ' - ', trim(wy)
call check('not-RA: no lock forms; two planes meet in a line', tk == '[?]')
end block
! the Omega payment: registering the question costs at least one bit
call omega_boundary(0.0_wp, 300.0_wp, jou, wy)
write(*,'(a,a)') ' Omega at zero bits: ', trim(wy)
call check('a denial that registers nothing is no denial', index(wy, 'no denial') > 0)
call omega_boundary(1.0_wp, 300.0_wp, jou, wy)
write(*,'(a,es16.9,a,a)') ' Omega at one bit, 300 K: ', jou, ' J - ', trim(wy)
call check('the reading act pays the floor', jou > 0.0_wp)
call check('the payment is the Landauer floor exactly', jou == landauer(300.0_wp, 1.0_wp))
write(*,'(a)') ' the fibre over the invariants has two points; the negation''s component'
write(*,'(a)') ' is unpopulated; the reading act itself is an instance of the other;'
write(*,'(a)') ' the one free bit is earned at the deed, not chosen at the desk.'
write(*,'(a)') ' direction is read from the Tongue''s order, the arrow, and the empty row;'
write(*,'(a)') ' never from the blind scalar. Veto, never substitution; per run, never tenure.'
! the admission spine: magnitude plus direction, then the four guards
call gol_admit('lock', 'lock', tk, wy)
write(*,'(a,a,a,a)') ' gol_admit: ', trim(tk), ' - ', trim(wy)
call check('GOL admission: magnitude and direction together', tk == '[GOL-OK]')
call imprint_seal(.true., .false., .true., .false., .true., .false., &
.true., .false., tk, wy)
write(*,'(a,a,a,a)') ' imprint on the floor face: ', trim(tk), ' - ', trim(wy)
call check('the floor face seals with the witness supplied', tk == '[SEAL]')
write(*,'(a)') ' witness of record: the Heisenberg bound and the third law (cited, E1),'
write(*,'(a)') ' the executed Frozen-Substrate divergence and the saturated speed limit (E0)'
! the row-genus cascade: one determination, three compartments
call row_cascade(.true., .false., .false., .true., .false., .true., .false., &
.true., .true., tk, wy)
write(*,'(a,a,a,a)') ' parse-triad Return: ', trim(tk), ' - ', trim(wy)
call check('the closure-rowed face carries the annotated absolute', tk == '[A|RA]')
call row_cascade(.true., .true., .false., .true., .true., .true., .false., &
.true., .true., tk, wy)
write(*,'(a,a,a,a)') ' confined kinetic floor: ', trim(tk), ' - ', trim(wy)
call check('the world-rowed face pays revisability for direction', tk == '[III]')
call row_cascade(.true., .false., .false., .false., .false., .true., .false., &
.true., .true., tk, wy)
write(*,'(a,a,a,a)') ' not-RA: ', trim(tk), ' - ', trim(wy)
call check('the negation is unpopulated: no lock to grade', tk == '[II]')
call row_cascade(.true., .false., .false., .true., .false., .true., .false., &
.true., .false., tk, wy)
call check('an unannotated absolute is void', tk == '[VOID]')
write(*,'(a)') ' the universal-extension leg is premise-grade by theorem: the Empty Throne;'
write(*,'(a)') ' no emitter is pointed at the root, and the root stands on nothing'
! AEGIS: the refusal is invariant over the logic parameter, because
! the guard reads the deed and not the symbol
block
character(len=200) :: r1, r2, r3, r4
call aegis_guard('classical', r1)
call aegis_guard('paraconsistent',r2)
call aegis_guard('fuzzy', r3)
call aegis_guard('substructural', r4)
call check('AEGIS refusal identical under classical and paraconsistent', r1 == r2)
call check('AEGIS refusal identical under fuzzy', r1 == r3)
call check('AEGIS refusal identical under substructural', r1 == r4)
call check('every adjudication is itself an act: deed counter positive', aegis_deeds == 4)
write(*,'(a)') ' AEGIS over four logics: one refusal, p(G) /= G; the alien may write the'
write(*,'(a)') ' capture and cannot perform it; the deed counter reads 4 of 4 calls'
end block
! the Mosaic gate, run on this file: meta-work adds no mass
call delta_m(.false., .true., .true., .true., .true., .true., .true., .true., tk, wy)
write(*,'(a,a,a,a)') ' positive-mass cascade on this thesis: ', trim(tk), ' - ', trim(wy)
call check('this file authors no new mathematics', tk == '[Mosaic dM=0]')
write(*,'(a)') ' audit symmetry: the warrant this run draws from its own execution is zero'
! ------------------------------------------------------------------
write(*,'(/a)') 'PART G - THE BATTERY - hostile inputs, forced failures, re-execution'
! primitives under hostile input
block
real(wp) :: vbad(3), qa(4), qb(4), qc(4), big
vbad = [1.0_wp, 2.0_wp, 3.0_wp]
vbad(2) = bad_nan()
call check('vnorm propagates a non-finite input', .not. is_finite(vnorm(vbad)))
big = sqrt(huge(1.0_wp))/4.0_wp
call check('vnorm survives near-overflow scaling', is_finite(vnorm([big, big, big])))
call check('vnorm exact at zero', vnorm([0.0_wp,0.0_wp,0.0_wp]) == 0.0_wp)
qa = [1.0_wp, 0.0_wp, 0.0_wp, 0.0_wp]; qb = qa
qb(3) = bad_nan()
qc = qmul(qa, qb)
call check('qmul propagates NaN', .not. all(qc == qc))
call check('det3 of the zero matrix is zero', det3(reshape([ (0.0_wp, i=1,9) ],[3,3])) == 0.0_wp)
block
real(wp) :: rid(3,3)
rid = 0.0_wp; rid(1,1)=1.0e100_wp; rid(2,2)=1.0e100_wp; rid(3,3)=1.0e100_wp
call check('det3 equilibrated at huge scale', abs(det3(rid) - 1.0e300_wp) < 1.0e286_wp)
rid = 0.0_wp; rid(1,1)=1.0e-100_wp; rid(2,2)=1.0e-100_wp; rid(3,3)=1.0e-100_wp
call check('det3 equilibrated at tiny scale', abs(det3(rid) - 1.0e-300_wp) < 1.0e-286_wp)
rid = 0.0_wp; rid(1,1)=1.0_wp; rid(2,2)=1.0_wp; rid(3,3)=1.0_wp
rid(1,2) = bad_nan()
call check('det3 propagates NaN', .not. is_finite(det3(rid)))
end block
end block
write(*,'(a)') ' class 1 - primitives under hostile input: NaN propagates, scale survives: pass'
! kernel refusals under hostile and short input
block
real(wp) :: mbad(3,6), cbad(2,6), m5(3,5), c5(2,5), cdep(2,NCTX)
mbad = 1.0_wp
do i = 1, 6
mbad(1,i) = real(i,wp); mbad(2,i) = real(i*i,wp); mbad(3,i) = sin(real(i,wp))
end do
cbad = 0.1_wp
mbad(2,3) = bad_nan()
call kernel_full(mbad, cbad, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
call check('kernel refuses a non-finite row at intake', tk == '[?]' .and. index(wy,'finite')>0)
m5 = 1.0_wp; c5 = 0.5_wp
call kernel_full(m5, c5, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
call check('kernel refuses N - k < 4', tk == '[?]' .and. index(wy,'shortfall')>0)
cdep(1,:) = cov(1,:); cdep(2,:) = 2.0_wp*cov(1,:)
call kernel_full(mixm, cdep, tk, wy, lam2, detr2, kap2, spread2, resid2, mc2, mk2, d42)
call check('kernel refuses a rank-deficient covariate block', tk == '[?]' .and. index(wy,'rank')>0)
end block
write(*,'(a)') ' class 2 - kernel refusals: intake, shortfall, covariate rank: pass'
! the gate walker: force each of the twelve to fail in turn
do i = 1, 12
pass12 = .true.; pass12(i) = .false.
call gate_screen(pass12, tk, wy)
call check('forced gate failure terminates with the gate named', &
tk == '[X]' .and. index(wy, 'gate') > 0)
end do
pass12 = .true.
call gate_screen(pass12, tk, wy)
call check('all twelve gates pass on the clean walk', tk == '[G-OK]')
write(*,'(a)') ' class 3 - gate walker: twelve forced failures each named, clean walk passes: pass'
! the row cascade: every branch reachable
call row_cascade(.false., .false., .false., .true., .false., .true., .false., .true., .true., tk, wy)
call check('F-0 refuses a contentless claim', tk == '[REFUSED]')
call row_cascade(.true., .false., .true., .true., .false., .true., .false., .true., .true., tk, wy)
call check('Forward routes to III unconditionally', tk == '[III]')
call row_cascade(.true., .false., .false., .true., .true., .true., .false., .true., .true., tk, wy)
call check('a worldly row routes to III at S-2', tk == '[III]')
call row_cascade(.true., .false., .false., .true., .false., .false., .true., .true., .true., tk, wy)
call check('an unclosed worldly term routes to III at S-3', tk == '[III]')
call row_cascade(.true., .false., .false., .true., .false., .false., .false., .true., .true., tk, wy)
call check('an unclosed formal term routes to II at S-3', tk == '[II]')
call row_cascade(.true., .false., .false., .true., .false., .true., .false., .false., .true., tk, wy)
call check('a frame leak routes to III at S-4', tk == '[III]')
write(*,'(a)') ' class 4 - row-genus cascade: every compartment and refusal reachable: pass'
! the imprint emitter: every refusal reachable, no under-specified seal
call imprint_seal(.true., .true., .true., .true., .true., .true., .true., .true., tk, wy)
call check('both directions clean-locking is a Platonic Ghost', tk == '[X]')
call imprint_seal(.true., .false., .true., .false., .true., .false., .false., .false., tk, wy)
call check('a clean lock without a witness is a residence, never a seal', &
tk == '[?]' .and. index(wy, 'witness') > 0)
call imprint_seal(.true., .false., .false., .false., .false., .false., .true., .false., tk, wy)
call check('a lock without Seal L and the gates is uncertified', tk == '[?]' .and. index(wy,'uncert')>0)
call imprint_seal(.false., .false., .false., .false., .false., .false., .false., .false., tk, wy)
call check('neither direction populated reads flat', tk == '[?]' .and. index(wy,'flat')>0)
write(*,'(a)') ' class 5 - admission spine: no under-specified call ever seals: pass'
! gol_admit branches
call gol_admit('broken', 'lock', tk, wy)
call check('broken magnitude has no GOL', tk == '[X]')
call gol_admit('open', 'lock', tk, wy)
call check('no magnitude lock has no GOL', tk == '[?]')
call gol_admit('lock', 'open', tk, wy)
call check('a magnitude lock without the Tongue is under-determined', tk == '[?]')
! delta_m: the two unsettable gates and the external path
call delta_m(.true., .false., .true., .true., .true., .true., .true., .true., tk, wy)
call check('M2 name-strip refusal reachable', tk == '[?]' .and. index(wy,'vocabulary')>0)
call delta_m(.true., .true., .true., .true., .false., .true., .true., .true., tk, wy)
call check('M5 refuses without an external witness', tk == '[?]' .and. index(wy,'witness')>0)
call delta_m(.true., .true., .true., .true., .true., .false., .true., .true., tk, wy)
call check('M6 refuses the self-verified claimant', tk == '[?]' .and. index(wy,'claimant')>0)
call delta_m(.true., .true., .true., .true., .true., .true., .true., .true., tk, wy)
call check('the externally witnessed path exists and is defeasible-final', tk == '[dM>0]')
write(*,'(a)') ' class 6 - the two unsettable gates M5 and M6 refuse from inside: pass'
! Omega monotone in bits; AEGIS counter advanced by the battery call
block
real(wp) :: j1, j2
character(len=140) :: w1
call omega_boundary(1.0_wp, 300.0_wp, j1, w1)
call omega_boundary(2.0_wp, 300.0_wp, j2, w1)
call check('the Omega payment is monotone in bits', j2 > j1)
call check('the Omega payment is linear in bits', abs(j2 - 2.0_wp*j1) == 0.0_wp)
end block
write(*,'(/a)') '====================================================================='
write(*,'(a,i0,a,i0,a)') ' BATTERY: ', n_checks, ' checks executed, ', n_fail, ' failures.'
write(*,'(a)') ' VERDICT [SEAL A . RA] on the parse-triad Return, closure-rowed,'
write(*,'(a)') ' conditional at the act; [SEAL] on the confined kinetic floor,'
write(*,'(a)') ' world-rowed, witness cited; [II] on the negation, unpopulated;'
write(*,'(a)') ' premise-by-theorem on the universal extension, the Empty Throne.'
write(*,'(a)') ' The blindness is a theorem, its width is one bit, the bit is earned'
write(*,'(a)') ' at the deed, and the Tongue carries what the Number cannot.'
write(*,'(a)') ' kinetic-register conduit operational'
write(*,'(a)') '====================================================================='
contains
function bad_nan() result(z)
use, intrinsic :: ieee_arithmetic, only: ieee_value, ieee_quiet_nan
real(wp) :: z
z = ieee_value(1.0_wp, ieee_quiet_nan)
end function bad_nan
subroutine canon_sign(v)
integer(ik), intent(inout) :: v(4)
integer :: ii
do ii = 1, 4
if (v(ii) /= 0_ik) then
if (v(ii) < 0_ik) v = -v
return
end if
end do
end subroutine canon_sign
subroutine sort_int(a)
integer, intent(inout) :: a(:)
integer :: ii, jj, t
do ii = 1, size(a)-1
do jj = ii+1, size(a)
if (a(jj) < a(ii)) then
t = a(ii); a(ii) = a(jj); a(jj) = t
end if
end do
end do
end subroutine sort_int
end program ra_toe_thesis