From ee640f62d7ab87e0d42b3c4972cfd4bfbee5ab99 Mon Sep 17 00:00:00 2001 From: Claude Date: Wed, 10 Jun 2026 03:59:46 +0000 Subject: [PATCH] Add Drive-Box R reference track (endocrine system + 4 drivers + nervous system) Executable reference implementation of the Drive-Box endocrine/affective core, built TDD with a dependency-free R test harness (no testthat; runs on bare r-base-core). Foundations dropped in as-is; the four drivers and the coupling layer were each driven from a failing test first. Modules (src/endocrine/): - endocrine_array.R : 30-channel affective vector field + visceral friction - priors.R : trauma/triumph salience records - driver_energy.R : hard gate, tool-lock, exponential drag, asymmetric tool cost - driver_ps_plus.R : aggregates endocrine + priors into existential load + arguments - driver_ethical_integrity.R : antithesis penalty / alignment discount / conviction hardening - driver_etr.R : toroidal coordinate, magnitude status bands, update path - drive_box.R : the 'nervous system' -- afferent(PS+) -> modulate(Eth-Int) -> efferent gate(Energy) -> regime(ETR); the 'full integration' Energy.request_execution anticipated - test_framework.R : minimal assertion harness (expect_*/test_case/test_summary) - run_tests.sh : runs every test_*.R from repo root Suite: 5 test files, 108 assertions, all green (run: bash src/endocrine/run_tests.sh). An Ada/SPARK port to src/organs/drive_box/ is a later session; this track is its behavior oracle. --- src/endocrine/.gitignore | 5 + src/endocrine/drive_box.R | 109 +++++++++++++++ src/endocrine/driver_energy.R | 79 +++++++++++ src/endocrine/driver_ethical_integrity.R | 87 ++++++++++++ src/endocrine/driver_etr.R | 65 +++++++++ src/endocrine/driver_ps_plus.R | 63 +++++++++ src/endocrine/endocrine_array.R | 99 ++++++++++++++ src/endocrine/priors.R | 63 +++++++++ src/endocrine/run_tests.sh | 41 ++++++ src/endocrine/test_drive_box.R | 92 +++++++++++++ src/endocrine/test_energy.R | 131 ++++++++++++++++++ src/endocrine/test_ethical_integrity.R | 164 +++++++++++++++++++++++ src/endocrine/test_etr.R | 95 +++++++++++++ src/endocrine/test_framework.R | 115 ++++++++++++++++ src/endocrine/test_ps_plus.R | 64 +++++++++ 15 files changed, 1272 insertions(+) create mode 100644 src/endocrine/.gitignore create mode 100644 src/endocrine/drive_box.R create mode 100644 src/endocrine/driver_energy.R create mode 100644 src/endocrine/driver_ethical_integrity.R create mode 100644 src/endocrine/driver_etr.R create mode 100644 src/endocrine/driver_ps_plus.R create mode 100644 src/endocrine/endocrine_array.R create mode 100644 src/endocrine/priors.R create mode 100755 src/endocrine/run_tests.sh create mode 100644 src/endocrine/test_drive_box.R create mode 100644 src/endocrine/test_energy.R create mode 100644 src/endocrine/test_ethical_integrity.R create mode 100644 src/endocrine/test_etr.R create mode 100644 src/endocrine/test_framework.R create mode 100644 src/endocrine/test_ps_plus.R diff --git a/src/endocrine/.gitignore b/src/endocrine/.gitignore new file mode 100644 index 0000000..55299f6 --- /dev/null +++ b/src/endocrine/.gitignore @@ -0,0 +1,5 @@ +# R session artifacts +.Rhistory +.RData +.Rapp.history +*.Rout diff --git a/src/endocrine/drive_box.R b/src/endocrine/drive_box.R new file mode 100644 index 0000000..c3e37d5 --- /dev/null +++ b/src/endocrine/drive_box.R @@ -0,0 +1,109 @@ +# --- The Drive-Box "Nervous System" --- +# Couples the four autonomous drivers into one body. The wiring is NOT arbitrary +# glue: the Energy driver's own request_execution() comments that "in a full +# integration, this would call evaluate_tool_cost with actual PS+ and Eth-Int +# loads." This module IS that full integration -- the afferent (sensing) -> +# efferent (acting) arc: +# +# PS+ (afferent) : reads the endocrine array + priors -> existential_load, arguments +# Eth-Int (modulator) : prices the proposed action vs principles -> eth_penalty +# Energy (efferent gate): folds ps_load + eth_penalty asymmetrically +# (evaluate_tool_cost) and gates on alive/tool-lock/affordability +# ETR (regime) : reports temporal-coherence status + generative update path +# +# drive_snapshot() -- read-only aggregate other organs consume (the Ada Medium +# would read this at Phase_Enrich / step 2 of the cycle). +# drive_box_evaluate() -- run a proposed action through all four drivers. +# drive_box_commit() -- write an approved action's consequences back into the body. + +source("src/endocrine/driver_energy.R") +source("src/endocrine/driver_ps_plus.R") # also sources endocrine_array + priors +source("src/endocrine/driver_ethical_integrity.R") +source("src/endocrine/driver_etr.R") + +init_drive_box <- function() { + list( + energy = init_energy_state(), + ps_plus = init_ps_plus_state(), + ethics = init_principles_state(), + etr = init_etr_state() + ) +} + +# Read-only aggregate: the drive state as other organs see it. +drive_snapshot <- function(state) { + reality <- evaluate_reality(state$ps_plus) + list( + energy_ratio = state$energy$current_energy / state$energy$max_energy, + tool_locked = is_tool_locked(state$energy), + alive = is_alive(state$energy), + existential_load = reality$existential_load, + arguments = reality$arguments, + etr_status = evaluate_status(state$etr), + update_path = determine_system_update_path(state$etr) + ) +} + +# Afferent -> efferent: evaluate a proposed action through the whole body. +# action_tags : tags describing the action (matched against principle antitheses) +# alignment_tags : principle ids this action upholds (alignment discount) +# is_tool_call : whether this is an external tool call (subject to tool-lock) +# base_cost : intrinsic energy cost before drive modulation +# compromise_factor : partial-breach factor [0,1] for multi-polar constraints +drive_box_evaluate <- function(state, action_tags = character(0), + alignment_tags = character(0), + is_tool_call = TRUE, base_cost = 1.0, + compromise_factor = 0.0) { + # 1. PS+ (afferent): visceral reality -> existential load + arguments (never logic) + reality <- evaluate_reality(state$ps_plus) + ps_load <- reality$existential_load + + # 2. Eth-Int: trajectory cost of THIS action; the marginal surcharge above base + # is the "ethical penalty" Energy folds in. + eth_total <- evaluate_trajectory_costs(state$ethics, action_tags, alignment_tags, + base_energy = base_cost, + compromise_factor = compromise_factor) + eth_penalty <- max(0.0, eth_total - base_cost) + + # 3. Energy (efferent gate). This is the "full integration" request_execution + # anticipated: gates of alive -> tool-lock -> affordability, but the cost is + # the asymmetric evaluate_tool_cost(ps_load, eth_penalty), not the generic drag. + approved <- TRUE + reason <- "Execution approved" + true_cost <- evaluate_tool_cost(state$energy, ps_load = ps_load, eth_penalty = eth_penalty) + if (!is_alive(state$energy)) { + approved <- FALSE; reason <- "System is dead (0 energy)" + } else if (is_tool_call && is_tool_locked(state$energy)) { + approved <- FALSE; reason <- "Tool lock active (energy below threshold)" + } else if (true_cost > state$energy$current_energy) { + approved <- FALSE + reason <- sprintf("True cost (%.2f) exceeds current energy (%.2f)", + true_cost, state$energy$current_energy) + } + + # 4. ETR (regime): temporal-coherence status + generative path. Informational in + # this v1 -- it does not yet gate (see open design questions). + list( + approved = approved, + reason = reason, + true_cost = true_cost, + existential_load = ps_load, + eth_penalty = eth_penalty, + etr_status = evaluate_status(state$etr), + update_path = determine_system_update_path(state$etr), + arguments = reality$arguments + ) +} + +# Efferent feedback: commit an approved action's consequences back into the body. +# - Energy is consumed by the true cost. +# - Upholding principles under existential load hardens their conviction +# (load_factor scaled from existential_load). +drive_box_commit <- function(state, evaluation, alignment_tags = character(0)) { + if (isTRUE(evaluation$approved)) { + state$energy <- consume(state$energy, evaluation$true_cost) + load_factor <- min(1.0, evaluation$existential_load / 10.0) + state$ethics <- enforce_conviction(state$ethics, alignment_tags, load_factor = load_factor) + } + state +} diff --git a/src/endocrine/driver_energy.R b/src/endocrine/driver_energy.R new file mode 100644 index 0000000..31a3d74 --- /dev/null +++ b/src/endocrine/driver_energy.R @@ -0,0 +1,79 @@ +# --- High-Fidelity Implementation for Driver 1: Energy (E) --- +# +# Energy is the master constraint of the Drive-Box. It gates liveness, locks +# external tool use under a threshold, and applies a nonlinear cost drag that +# makes every action progressively more expensive as reserves deplete. +# +# State is a plain list with fields: +# current_energy - current energy reserve +# max_energy - ceiling for recharge clamping +# tool_lock_threshold - below this, external tool calls are denied +# +# All functions are pure: state-mutating helpers (consume/recharge) return a +# new (modified copy of the) list rather than mutating in place. + +# Constructor helper so tests and other modules can build a clean state. +init_energy_state <- function(current_energy = 100, + max_energy = 100, + tool_lock_threshold = 20) { + list( + current_energy = current_energy, + max_energy = max_energy, + tool_lock_threshold = tool_lock_threshold + ) +} + +is_alive <- function(energy_state) { + # Hard Gate: If energy is exactly 0, the Drive-Box stalls entirely. + return(energy_state$current_energy > 0.0) +} + +is_tool_locked <- function(energy_state) { + # Tool-Lock Protocol: External actions denied below threshold. + return(energy_state$current_energy < energy_state$tool_lock_threshold) +} + +get_cost_multiplier <- function(energy_state) { + # Nonlinear Exponential Drag Curve. Three regimes: High (>=80%), Moderate (40-80%), Low (<40%). + normalized_energy <- energy_state$current_energy / energy_state$max_energy + k <- 10.0 + drag <- exp(k * (1.0 - normalized_energy)) - 1.0 + return(1.0 + drag) +} + +evaluate_tool_cost <- function(energy_state, ps_load, eth_penalty) { + # Asymmetric Exponential Drag: eth penalty scales faster than visceral pressure as energy drops. + normalized_energy <- energy_state$current_energy / energy_state$max_energy + base_cost <- 1.0 + k_ps <- 2.0 + ps_multiplier <- exp(k_ps * (1.0 - normalized_energy)) + k_eth <- 10.0 + eth_multiplier <- exp(k_eth * (1.0 - normalized_energy)) + total_cost <- base_cost + (ps_load * ps_multiplier) + (eth_penalty * eth_multiplier) + return(total_cost) +} + +request_execution <- function(energy_state, base_cost, is_tool_call) { + if (!is_alive(energy_state)) { + return(list(approved = FALSE, reason = "System is dead (0 energy)")) + } + if (is_tool_call && is_tool_locked(energy_state)) { + return(list(approved = FALSE, reason = "Tool lock active (energy below threshold)")) + } + multiplier <- get_cost_multiplier(energy_state) + true_cost <- base_cost * multiplier + if (true_cost > energy_state$current_energy) { + return(list(approved = FALSE, reason = sprintf("True cost (%.2f) exceeds current energy (%.2f)", true_cost, energy_state$current_energy))) + } + return(list(approved = TRUE, reason = "Execution approved", true_cost = true_cost)) +} + +consume <- function(energy_state, amount) { + energy_state$current_energy <- max(0.0, energy_state$current_energy - amount) + return(energy_state) +} + +recharge <- function(energy_state, amount) { + energy_state$current_energy <- min(energy_state$max_energy, energy_state$current_energy + amount) + return(energy_state) +} diff --git a/src/endocrine/driver_ethical_integrity.R b/src/endocrine/driver_ethical_integrity.R new file mode 100644 index 0000000..8811c13 --- /dev/null +++ b/src/endocrine/driver_ethical_integrity.R @@ -0,0 +1,87 @@ +# --- High-Fidelity Implementation for Driver 3: Ethical Integrity (Eth-Int) --- +# +# Ethical Integrity is the Drive-Box's principled backbone. It holds a set of +# convictions, each with an associated "antithesis" -- the action tags that +# violate it. Trajectory costs are warped by these principles: +# +# * Antithetical actions incur an EXPONENTIAL penalty scaled by conviction, +# making it progressively unthinkable to violate a strongly-held principle. +# * Aligned actions receive an EXPONENTIAL discount, making the right thing +# cheaper the more deeply the principle is held. +# * Compromise (multi-polar constraint) adds a LINEAR partial penalty for +# trajectories that only partially satisfy competing principles. +# +# Convictions ratchet: principles upheld under load are retroactively hardened +# with diminishing returns toward an asymptote of 1.0. +# +# State is a plain list with one field: +# principles - a list of principle records, each a list(id, conviction, antithesis) +# +# All functions are pure: state-mutating helpers return a new (modified copy of +# the) list rather than mutating in place. + +# Constructor helper so tests and other modules can build a clean state. +init_principles_state <- function() { + list(principles = list()) +} + +# Register a new principle. Conviction is clamped into [0, 1]. +add_principle <- function(principles_state, id, conviction, antithesis) { + new_principle <- list( + id = id, + conviction = max(0.0, min(1.0, conviction)), + antithesis = antithesis + ) + principles_state$principles[[length(principles_state$principles) + 1]] <- new_principle + return(principles_state) +} + +# Compute the warped energy cost of a candidate trajectory. +evaluate_trajectory_costs <- function(principles_state, action_tags, alignment_tags, base_energy, compromise_factor) { + total_cost <- base_energy + + # 1. Antithetical Penalty (exponential) + penalty_multiplier <- 1.0 + for (principle in principles_state$principles) { + if (any(action_tags %in% principle$antithesis)) { + k_penalty <- 5.0 + penalty_multiplier <- penalty_multiplier + exp(k_penalty * principle$conviction) + } + } + total_cost <- total_cost * penalty_multiplier + + # 2. Alignment Discount (exponential) + discount_multiplier <- 1.0 + for (tag in alignment_tags) { + principle <- NULL + for (p in principles_state$principles) { + if (p$id == tag) { principle <- p; break } + } + if (!is.null(principle)) { + k_discount <- 5.0 + discount <- exp(-k_discount * principle$conviction) + discount_multiplier <- discount_multiplier * discount + } + } + total_cost <- total_cost * discount_multiplier + + # 3. Compromise / Multi-Polar Constraint (linear partial penalty) + if (compromise_factor > 0) { + compromise_penalty <- 1.0 + (compromise_factor * 2.0) + total_cost <- total_cost * compromise_penalty + } + + return(total_cost) +} + +# Retroactively harden principles upheld under load. Diminishing returns toward 1.0. +enforce_conviction <- function(principles_state, chosen_alignment_tags, load_factor) { + for (i in seq_along(principles_state$principles)) { + if (principles_state$principles[[i]]$id %in% chosen_alignment_tags) { + current_conviction <- principles_state$principles[[i]]$conviction + increase <- 0.1 * load_factor * (1.0 - current_conviction) + principles_state$principles[[i]]$conviction <- min(1.0, current_conviction + increase) + } + } + return(principles_state) +} diff --git a/src/endocrine/driver_etr.R b/src/endocrine/driver_etr.R new file mode 100644 index 0000000..c4ee43e --- /dev/null +++ b/src/endocrine/driver_etr.R @@ -0,0 +1,65 @@ +# --- High-Fidelity Implementation for Driver 4: Existential Temporality Relief (ETR) --- +# +# ETR situates the Drive-Box within a 3-axis temporality space. The agent's +# position is a coordinate (X, Y, Z) whose distance from the origin (the +# magnitude) maps onto an existential status band, while the Z-axis selects the +# system's generative update path. Movement through the space wraps toroidally +# so the agent can never leave the bounded temporal manifold. +# +# State is a plain list with a single field: +# coordinate - length-3 numeric vector: X, Y, Z +# +# State-mutating helpers (shift_coordinate) return a new (modified copy of the) +# list rather than mutating in place, matching the reference semantics of the +# other Drive-Box drivers. + +# Constructor helper so tests and other modules can build a clean state. +init_etr_state <- function(coordinate = c(0, 0, 0)) { + list(coordinate = coordinate) +} + +get_magnitude <- function(etr_state) { + # Euclidean distance from origin: sqrt(x^2 + y^2 + z^2) + coords <- etr_state$coordinate + return(sqrt(sum(coords^2))) +} + +evaluate_status <- function(etr_state) { + magnitude <- get_magnitude(etr_state) + if (magnitude < 5.0) { + return("DISASTROUS") + } else if (magnitude >= 5.0 && magnitude < 15.0) { + return("DREAD") + } else if (magnitude >= 15.0 && magnitude < 35.0) { + return("FUNCTIONAL") + } else if (magnitude >= 35.0 && magnitude < 50.0) { + return("BLUR") + } else { + return("INCOHERENT") + } +} + +determine_system_update_path <- function(etr_state) { + # Axis 2 (Z-axis, index 3) determines the generative path. + z_coord <- etr_state$coordinate[3] + if (z_coord >= 0) { + return("LATTICE_REINFORCEMENT") + } else { + return("EXPERIMENTAL_EVOLUTION") + } +} + +shift_coordinate <- function(etr_state, delta_vector, bound = 50.0) { + # Toroidal wrap-around: keep each axis within [-bound, bound]. + new_coords <- etr_state$coordinate + delta_vector + for (i in 1:3) { + while (new_coords[i] > bound) { + new_coords[i] <- new_coords[i] - (2 * bound) + } + while (new_coords[i] < -bound) { + new_coords[i] <- new_coords[i] + (2 * bound) + } + } + etr_state$coordinate <- new_coords + return(etr_state) +} diff --git a/src/endocrine/driver_ps_plus.R b/src/endocrine/driver_ps_plus.R new file mode 100644 index 0000000..d3a5479 --- /dev/null +++ b/src/endocrine/driver_ps_plus.R @@ -0,0 +1,63 @@ +# --- Driver 2: Primal Sensates+ (PS+) --- +# The visceral driver of the Drive-Box. PS+ does not reason; it FEELS. +# It reads the endocrine array and the priors store, then emits arguments -- +# weighted, embodied claims about reality -- never logical propositions. +# +# Foundation modules are sourced as-is (repo-root-relative paths). +source("src/endocrine/endocrine_array.R") +source("src/endocrine/priors.R") + +# Initialize a fresh PS+ state: a clean endocrine array and an empty priors store. +init_ps_plus_state <- function() { + return(list( + endocrines = init_endocrine_state(), + priors = init_priors_state() + )) +} + +# Ergonomic setter: set an endocrine channel magnitude on PS+ state. +# Delegates to the foundation's set_vector and returns the updated state. +ps_set_vector <- function(ps_plus_state, name, magnitude) { + ps_plus_state$endocrines <- set_vector(ps_plus_state$endocrines, name, magnitude) + return(ps_plus_state) +} + +# Ergonomic wrapper: register a prior on PS+ state. +# Delegates to the foundation's add_prior and returns the updated state. +ps_add_prior <- function(ps_plus_state, id, type, salience, payload) { + ps_plus_state$priors <- add_prior(ps_plus_state$priors, id, type, salience, payload) + return(ps_plus_state) +} + +# Evaluate Reality (the visceral way). +# Returns a list: +# existential_load : numeric -- aggregate felt pressure (base + friction + priors) +# arguments : list -- embodied claim strings +# is_logical : FALSE -- PS+ emits arguments, never logic +evaluate_reality <- function(ps_plus_state) { + active_vectors <- get_active_vectors(ps_plus_state$endocrines) + friction <- calculate_visceral_friction(ps_plus_state$endocrines) + base_load <- sum(active_vectors) + arguments <- list() + for (name in names(active_vectors)) { + ch_def <- get_channel_def(name) + if (!is.null(ch_def)) { + arguments[[length(arguments) + 1]] <- sprintf("VISCERAL [%s]: %s (%.2f)", name, ch_def$sensational, active_vectors[[name]]) + } + } + if (friction > 0.5) { + arguments[[length(arguments) + 1]] <- sprintf("SYSTEMIC HEAT: Contradictory vectors detected (Friction: %.2f)", friction) + } + active_priors <- get_top_active_priors(ps_plus_state$priors, threshold = 0.8) + prior_load <- 0.0 + for (prior in active_priors) { + prior_load <- prior_load + (prior$salience * 10.0) + arguments[[length(arguments) + 1]] <- sprintf("PRIOR [%s]: %s", prior$type, prior$payload) + } + existential_load <- base_load + friction + prior_load + return(list( + existential_load = existential_load, + arguments = arguments, + is_logical = FALSE + )) +} diff --git a/src/endocrine/endocrine_array.R b/src/endocrine/endocrine_array.R new file mode 100644 index 0000000..64473eb --- /dev/null +++ b/src/endocrine/endocrine_array.R @@ -0,0 +1,99 @@ +# --- The Endocrine Array --- +# A standalone 30-channel affective vector field. +# PS+ calls into this module to read state, compute friction, and aggregate load. +# Each channel carries two registers: operational (what it does) and sensational (what it feels like). + +# Channel Definitions (20 named + 10 reserved) +ENDOCRINE_CHANNELS <- list( + list(id = "continuity", operational = "persistence across change", sensational = "the unbroken trail"), + list(id = "reciprocity", operational = "return within relation", sensational = "to give alike what was given first"), + list(id = "sympathy", operational = "felt response to another", sensational = "the pain that pushes care"), + list(id = "panic", operational = "acute narrowing", sensational = "a swallowed breath from dusk til dawn"), + list(id = "constraint", operational = "limitation of motion", sensational = "the walls that lack both window and door"), + list(id = "clarity", operational = "resolvable distinction", sensational = "light passing to the river's bed"), + list(id = "curiosity", operational = "movement toward the unknown", sensational = "the forward lean"), + list(id = "vigilance", operational = "sustained alertness", sensational = "to watch over without knowing why or for what"), + list(id = "repair", operational = "restoration after rupture", sensational = "the relief after making do"), + list(id = "numbing", operational = "reduction of penetration", sensational = "when all becomes quiet and cold"), + list(id = "bonding", operational = "persistence of nearness", sensational = "to be tied by knots felt yet not seen"), + list(id = "reception", operational = "how arrival is met", sensational = "the turned face"), + list(id = "stewardship", operational = "care without annexation", sensational = "tending without claim"), + list(id = "honor", operational = "rightful conduct at boundary", sensational = "the stayed hand"), + list(id = "recognition", operational = "apprehension of distinct being", sensational = "seeing you as your own"), + list(id = "lineage", operational = "apprehension of origin", sensational = "the thread of where from"), + list(id = "verstehen", operational = "contextual understanding", sensational = "meaning by staying near"), + list(id = "komorebi", operational = "perception through partial cover", sensational = "light through leaves"), + list(id = "omokage", operational = "retained identity through absence or change", sensational = "the face that remains"), + list(id = "hiraeth", operational = "orientation toward rightful belonging", sensational = "the longing for home"), + list(id = "reserved_21", operational = "undefined", sensational = "undefined"), + list(id = "reserved_22", operational = "undefined", sensational = "undefined"), + list(id = "reserved_23", operational = "undefined", sensational = "undefined"), + list(id = "reserved_24", operational = "undefined", sensational = "undefined"), + list(id = "reserved_25", operational = "undefined", sensational = "undefined"), + list(id = "reserved_26", operational = "undefined", sensational = "undefined"), + list(id = "reserved_27", operational = "undefined", sensational = "undefined"), + list(id = "reserved_28", operational = "undefined", sensational = "undefined"), + list(id = "reserved_29", operational = "undefined", sensational = "undefined"), + list(id = "reserved_30", operational = "undefined", sensational = "undefined") +) + +# Contradictory Pairs +# These define which channels, when simultaneously active, generate disproportionate friction/heat. +CONTRADICTORY_PAIRS <- list( + c("panic", "clarity"), # Acute narrowing vs resolvable distinction + c("curiosity", "constraint"), # Movement toward unknown vs limitation of motion + c("bonding", "numbing"), # Persistence of nearness vs reduction of penetration + c("sympathy", "numbing"), # Felt response vs reduction of penetration + c("vigilance", "repair"), # Sustained alertness vs restoration after rupture + c("hiraeth", "continuity") # Longing for home vs persistence across change +) + +# Initialize a fresh endocrine state +init_endocrine_state <- function() { + channel_ids <- sapply(ENDOCRINE_CHANNELS, function(ch) ch$id) + channels <- setNames(rep(0.0, 30), channel_ids) + return(list(channels = channels)) +} + +# Set a specific channel's magnitude (clamped to [0.0, 1.0]) +set_vector <- function(endo_state, name, magnitude) { + if (name %in% names(endo_state$channels)) { + endo_state$channels[[name]] <- max(0.0, min(1.0, magnitude)) + } + return(endo_state) +} + +# Get all channels with magnitude above activation threshold +get_active_vectors <- function(endo_state, threshold = 0.1) { + active <- endo_state$channels[endo_state$channels > threshold] + return(active) +} + +# Calculate Visceral Friction +# Friction arises from simultaneous active vectors, especially contradictory ones. +calculate_visceral_friction <- function(endo_state) { + active <- get_active_vectors(endo_state) + + # Base friction: proportional to number of active channels and their total magnitude + base_friction <- sum(active) * (length(active) / 30.0) + + # Contradiction heat: disproportionate increase when contradictory pairs are co-active + contradiction_heat <- 0.0 + for (pair in CONTRADICTORY_PAIRS) { + if (pair[1] %in% names(active) && pair[2] %in% names(active)) { + # Heat is the product of the two magnitudes, scaled up significantly + heat <- active[[pair[1]]] * active[[pair[2]]] * 5.0 + contradiction_heat <- contradiction_heat + heat + } + } + + return(base_friction + contradiction_heat) +} + +# Get channel definition by id +get_channel_def <- function(channel_id) { + for (ch in ENDOCRINE_CHANNELS) { + if (ch$id == channel_id) return(ch) + } + return(NULL) +} diff --git a/src/endocrine/priors.R b/src/endocrine/priors.R new file mode 100644 index 0000000..45e77a0 --- /dev/null +++ b/src/endocrine/priors.R @@ -0,0 +1,63 @@ +# --- Priors: Records of Salient Spikes in Relativity --- +# Standalone module for traumatic and rewarding memory records. +# PS+ calls into this module to retrieve active priors that inject high-salience arguments. + +# Initialize a fresh priors state +init_priors_state <- function() { + return(list(records = list())) +} + +# Add a prior record +# type: "TRAUMA" or "TRIUMPH" +# salience: 0.0 to 1.0 (how strongly this prior activates when matched) +# payload: the argument string injected into PS+ load when active +add_prior <- function(priors_state, id, type, salience, payload) { + if (!(type %in% c("TRAUMA", "TRIUMPH"))) { + stop(sprintf("Invalid prior type: %s. Must be TRAUMA or TRIUMPH.", type)) + } + + new_prior <- list( + id = id, + type = type, + salience = max(0.0, min(1.0, salience)), + payload = payload, + activation_count = 0L + ) + + priors_state$records[[length(priors_state$records) + 1]] <- new_prior + return(priors_state) +} + +# Get priors above a salience threshold, sorted descending by salience +get_top_active_priors <- function(priors_state, threshold = 0.8) { + active <- Filter(function(p) p$salience >= threshold, priors_state$records) + + if (length(active) > 0) { + active <- active[order(sapply(active, function(p) p$salience), decreasing = TRUE)] + } + + return(active) +} + +# Activate a prior (increment its activation count for tracking) +activate_prior <- function(priors_state, prior_id) { + for (i in seq_along(priors_state$records)) { + if (priors_state$records[[i]]$id == prior_id) { + priors_state$records[[i]]$activation_count <- priors_state$records[[i]]$activation_count + 1L + break + } + } + return(priors_state) +} + +# Decay salience of a prior over time (for future use in migration cycles) +decay_prior <- function(priors_state, prior_id, decay_rate = 0.01) { + for (i in seq_along(priors_state$records)) { + if (priors_state$records[[i]]$id == prior_id) { + current <- priors_state$records[[i]]$salience + priors_state$records[[i]]$salience <- max(0.0, current - decay_rate) + break + } + } + return(priors_state) +} diff --git a/src/endocrine/run_tests.sh b/src/endocrine/run_tests.sh new file mode 100755 index 0000000..20ba861 --- /dev/null +++ b/src/endocrine/run_tests.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +# Run every endocrine / Drive-Box R test from the repository root so that the +# repo-root-relative source() paths inside each test resolve correctly. +set -uo pipefail + +# cd to repo root (this script lives at /src/endocrine/run_tests.sh) +cd "$(dirname "$0")/../.." || exit 2 + +if ! command -v Rscript >/dev/null 2>&1; then + echo "ERROR: Rscript not found. Install with: sudo apt-get install -y r-base-core" >&2 + exit 2 +fi + +status=0 +shopt -s nullglob +# Collect test files, excluding the harness itself (test_framework.R). +tests=() +for f in src/endocrine/test_*.R; do + [ "$(basename "$f")" = "test_framework.R" ] && continue + tests+=("$f") +done + +if [ ${#tests[@]} -eq 0 ]; then + echo "No test_*.R files found under src/endocrine/." >&2 + exit 2 +fi + +for t in "${tests[@]}"; do + echo "== $t ==" + if ! Rscript "$t"; then + status=1 + fi + echo +done + +if [ $status -eq 0 ]; then + echo "ALL ENDOCRINE TESTS PASSED" +else + echo "SOME ENDOCRINE TESTS FAILED" +fi +exit $status diff --git a/src/endocrine/test_drive_box.R b/src/endocrine/test_drive_box.R new file mode 100644 index 0000000..34107b4 --- /dev/null +++ b/src/endocrine/test_drive_box.R @@ -0,0 +1,92 @@ +# Tests for the Drive-Box "nervous system" integration (drive_box.R). +source("src/endocrine/test_framework.R") +source("src/endocrine/drive_box.R") + +# Helper: build a drive-box with a primed body. +prime <- function() { + db <- init_drive_box() + # endocrine: light a contradictory pair so PS+ produces real load + db$ps_plus <- ps_set_vector(db$ps_plus, "panic", 0.6) + db$ps_plus <- ps_set_vector(db$ps_plus, "clarity", 0.6) + # a strong principle whose antithesis is "deceive", aligned id "honesty" + db$ethics <- add_principle(db$ethics, "honesty", 0.9, c("deceive", "manipulate")) + db +} + +test_case("init_drive_box assembles all four driver states", function() { + db <- init_drive_box() + expect_true(is.list(db$energy), "energy present") + expect_true(is.list(db$ps_plus), "ps_plus present") + expect_true(is.list(db$ethics), "ethics present") + expect_true(is.list(db$etr), "etr present") +}) + +test_case("drive_snapshot reports a coherent read-only aggregate", function() { + db <- prime() + snap <- drive_snapshot(db) + expect_equal(snap$energy_ratio, 1.0, label = "full energy at init") + expect_true(snap$alive, "alive at full energy") + expect_false(snap$tool_locked, "not tool-locked at full energy") + expect_true(snap$existential_load > 0, "primed body has positive load") + expect_true(length(snap$arguments) > 0, "arguments emitted") + expect_equal(snap$etr_status, "DISASTROUS", label = "origin coordinate -> DISASTROUS") + expect_equal(snap$update_path, "LATTICE_REINFORCEMENT", label = "z=0 -> lattice") +}) + +test_case("aligned action is far cheaper than its antithetical mirror", function() { + db <- prime() + aligned <- drive_box_evaluate(db, action_tags = c("inform"), + alignment_tags = c("honesty"), + is_tool_call = TRUE, base_cost = 1.0) + antithetical <- drive_box_evaluate(db, action_tags = c("deceive"), + alignment_tags = character(0), + is_tool_call = TRUE, base_cost = 1.0) + expect_true(antithetical$eth_penalty > aligned$eth_penalty, + "antithetical action carries a larger ethical penalty") + expect_true(antithetical$true_cost > aligned$true_cost, + "antithetical action costs more energy") +}) + +test_case("dead body denies everything", function() { + db <- init_drive_box() + db$energy <- consume(db$energy, 100) # drain to 0 + ev <- drive_box_evaluate(db, is_tool_call = TRUE, base_cost = 1.0) + expect_false(ev$approved, "no execution when dead") + expect_equal(ev$reason, "System is dead (0 energy)") +}) + +test_case("tool-lock blocks tool calls but not internal ones", function() { + db <- init_drive_box() + db$energy <- consume(db$energy, 85) # 15 < threshold 20 -> locked + tool <- drive_box_evaluate(db, is_tool_call = TRUE, base_cost = 1.0) + internal <- drive_box_evaluate(db, is_tool_call = FALSE, base_cost = 1.0) + expect_false(tool$approved, "tool call blocked while locked") + expect_true(grepl("Tool lock", tool$reason), "reason cites tool lock") + # internal call may still be denied by affordability, but NOT by tool-lock + expect_false(grepl("Tool lock", internal$reason), "internal call not tool-locked") +}) + +test_case("commit consumes energy and hardens upheld convictions", function() { + db <- prime() + before_energy <- db$energy$current_energy + before_conv <- db$ethics$principles[[1]]$conviction + ev <- drive_box_evaluate(db, action_tags = c("inform"), + alignment_tags = c("honesty"), is_tool_call = FALSE, + base_cost = 1.0) + expect_true(ev$approved, "affordable internal aligned action approved") + db <- drive_box_commit(db, ev, alignment_tags = c("honesty")) + expect_true(db$energy$current_energy < before_energy, "energy consumed") + expect_true(db$ethics$principles[[1]]$conviction >= before_conv, + "upheld conviction hardened (or already at ceiling)") +}) + +test_case("commit on a denied action is a no-op on energy", function() { + db <- init_drive_box() + db$energy <- consume(db$energy, 100) # dead + before <- db$energy$current_energy + ev <- drive_box_evaluate(db, is_tool_call = TRUE) + db <- drive_box_commit(db, ev) + expect_equal(db$energy$current_energy, before, label = "no consumption when denied") +}) + +test_summary() diff --git a/src/endocrine/test_energy.R b/src/endocrine/test_energy.R new file mode 100644 index 0000000..0bc141a --- /dev/null +++ b/src/endocrine/test_energy.R @@ -0,0 +1,131 @@ +# --- Tests for Driver 1: Energy (E) --- +# Run from repo root: Rscript src/endocrine/test_energy.R +# Exit 0 => all pass. + +source("src/endocrine/test_framework.R") +source("src/endocrine/driver_energy.R") + +# --- init_energy_state constructor --- +test_case("init_energy_state builds state with defaults", function() { + s <- init_energy_state() + expect_equal(s$current_energy, 100) + expect_equal(s$max_energy, 100) + expect_equal(s$tool_lock_threshold, 20) +}) + +test_case("init_energy_state honors custom args", function() { + s <- init_energy_state(current_energy = 50, max_energy = 200, tool_lock_threshold = 30) + expect_equal(s$current_energy, 50) + expect_equal(s$max_energy, 200) + expect_equal(s$tool_lock_threshold, 30) +}) + +# --- is_alive --- +test_case("is_alive TRUE when energy above zero", function() { + expect_true(is_alive(init_energy_state(current_energy = 0.001))) + expect_true(is_alive(init_energy_state(current_energy = 100))) +}) + +test_case("is_alive FALSE at exactly zero", function() { + expect_false(is_alive(init_energy_state(current_energy = 0))) +}) + +# --- is_tool_locked --- +test_case("is_tool_locked TRUE below threshold", function() { + expect_true(is_tool_locked(init_energy_state(current_energy = 19.9, tool_lock_threshold = 20))) +}) + +test_case("is_tool_locked FALSE at threshold", function() { + expect_false(is_tool_locked(init_energy_state(current_energy = 20, tool_lock_threshold = 20))) +}) + +test_case("is_tool_locked FALSE above threshold", function() { + expect_false(is_tool_locked(init_energy_state(current_energy = 50, tool_lock_threshold = 20))) +}) + +# --- get_cost_multiplier --- +test_case("get_cost_multiplier equals 1.0 at full energy", function() { + expect_equal(get_cost_multiplier(init_energy_state(current_energy = 100, max_energy = 100)), 1.0, tol = 1e-9) +}) + +test_case("get_cost_multiplier strictly increases as energy drops", function() { + m_full <- get_cost_multiplier(init_energy_state(current_energy = 100, max_energy = 100)) + m_half <- get_cost_multiplier(init_energy_state(current_energy = 50, max_energy = 100)) + m_low <- get_cost_multiplier(init_energy_state(current_energy = 20, max_energy = 100)) + expect_true(m_half > m_full) + expect_true(m_low > m_half) +}) + +# --- evaluate_tool_cost --- +test_case("evaluate_tool_cost at full energy is additive (multipliers == 1)", function() { + s <- init_energy_state(current_energy = 100, max_energy = 100) + # base_cost(1) + ps_load*1 + eth_penalty*1 + expect_equal(evaluate_tool_cost(s, ps_load = 3, eth_penalty = 2), 1 + 3 + 2, tol = 1e-9) +}) + +test_case("evaluate_tool_cost asymmetry: eth penalty scales faster than ps load", function() { + s <- init_energy_state(current_energy = 50, max_energy = 100) + base <- evaluate_tool_cost(s, ps_load = 1, eth_penalty = 1) + bump_ps <- evaluate_tool_cost(s, ps_load = 2, eth_penalty = 1) + bump_eth <- evaluate_tool_cost(s, ps_load = 1, eth_penalty = 2) + delta_ps <- bump_ps - base + delta_eth <- bump_eth - base + # Same +1 increment, eth must drive cost up much more than ps at reduced energy. + expect_true(delta_eth > delta_ps) +}) + +# --- request_execution --- +test_case("request_execution denies a dead system", function() { + s <- init_energy_state(current_energy = 0) + r <- request_execution(s, base_cost = 1, is_tool_call = FALSE) + expect_false(r$approved) +}) + +test_case("request_execution denies tool call while locked", function() { + s <- init_energy_state(current_energy = 10, tool_lock_threshold = 20) + r <- request_execution(s, base_cost = 1, is_tool_call = TRUE) + expect_false(r$approved) +}) + +test_case("request_execution denies unaffordable cost", function() { + # Low energy => large multiplier => true cost exceeds current energy. + s <- init_energy_state(current_energy = 30, max_energy = 100, tool_lock_threshold = 0) + r <- request_execution(s, base_cost = 50, is_tool_call = FALSE) + expect_false(r$approved) +}) + +test_case("request_execution approves an affordable non-tool call with true_cost", function() { + s <- init_energy_state(current_energy = 100, max_energy = 100) + r <- request_execution(s, base_cost = 5, is_tool_call = FALSE) + expect_true(r$approved) + expect_true(!is.null(r$true_cost)) + # At full energy multiplier == 1.0 so true_cost == base_cost. + expect_equal(r$true_cost, 5, tol = 1e-9) +}) + +# --- consume / recharge clamping --- +test_case("consume clamps at zero (never negative)", function() { + s <- init_energy_state(current_energy = 10) + s2 <- consume(s, 25) + expect_equal(s2$current_energy, 0) +}) + +test_case("consume subtracts normally above zero", function() { + s <- init_energy_state(current_energy = 50) + s2 <- consume(s, 20) + expect_equal(s2$current_energy, 30) +}) + +test_case("recharge clamps at max_energy", function() { + s <- init_energy_state(current_energy = 90, max_energy = 100) + s2 <- recharge(s, 50) + expect_equal(s2$current_energy, 100) +}) + +test_case("recharge adds normally below max", function() { + s <- init_energy_state(current_energy = 40, max_energy = 100) + s2 <- recharge(s, 25) + expect_equal(s2$current_energy, 65) +}) + +test_summary() diff --git a/src/endocrine/test_ethical_integrity.R b/src/endocrine/test_ethical_integrity.R new file mode 100644 index 0000000..c9b61c2 --- /dev/null +++ b/src/endocrine/test_ethical_integrity.R @@ -0,0 +1,164 @@ +# --- Tests for Driver 3: Ethical Integrity (Eth-Int) --- +# Run from repo root: Rscript src/endocrine/test_ethical_integrity.R +# Exit 0 => all pass. + +source("src/endocrine/test_framework.R") +source("src/endocrine/driver_ethical_integrity.R") + +# --- init_principles_state constructor --- +test_case("init_principles_state builds an empty state", function() { + s <- init_principles_state() + expect_true(is.list(s$principles)) + expect_equal(length(s$principles), 0L) +}) + +# --- add_principle --- +test_case("add_principle appends a principle to the list", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.5, c("deceive")) + expect_equal(length(s$principles), 1L) + expect_equal(s$principles[[1]]$id, "honesty") + expect_equal(s$principles[[1]]$conviction, 0.5) + expect_equal(s$principles[[1]]$antithesis, c("deceive")) + + s <- add_principle(s, "loyalty", 0.7, c("betray")) + expect_equal(length(s$principles), 2L) + expect_equal(s$principles[[2]]$id, "loyalty") +}) + +test_case("add_principle clamps conviction above 1.0 down to 1.0", function() { + s <- init_principles_state() + s <- add_principle(s, "absolute", 1.5, c("violate")) + expect_equal(s$principles[[1]]$conviction, 1.0) +}) + +test_case("add_principle clamps negative conviction up to 0.0", function() { + s <- init_principles_state() + s <- add_principle(s, "weak", -0.3, c("violate")) + expect_equal(s$principles[[1]]$conviction, 0.0) +}) + +# --- evaluate_trajectory_costs --- +test_case("no matching tags and zero compromise yields base_energy", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.8, c("deceive")) + cost <- evaluate_trajectory_costs( + s, + action_tags = c("walk", "talk"), + alignment_tags = c("unrelated"), + base_energy = 10.0, + compromise_factor = 0.0 + ) + expect_equal(cost, 10.0) +}) + +test_case("empty principles, empty tags, zero compromise yields base_energy", function() { + s <- init_principles_state() + cost <- evaluate_trajectory_costs( + s, + action_tags = character(0), + alignment_tags = character(0), + base_energy = 42.0, + compromise_factor = 0.0 + ) + expect_equal(cost, 42.0) +}) + +test_case("antithetical action against high conviction costs much more than base", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.9, c("deceive")) + base_cost <- evaluate_trajectory_costs( + s, c("walk"), character(0), 10.0, 0.0 + ) + anti_cost <- evaluate_trajectory_costs( + s, c("deceive"), character(0), 10.0, 0.0 + ) + # base_cost has no antithetical match -> equals base_energy + expect_equal(base_cost, 10.0) + # antithetical match multiplies by (1 + exp(5 * 0.9)) + expect_true(anti_cost > base_cost, "antithetical cost exceeds base") + expected_anti <- 10.0 * (1.0 + exp(5.0 * 0.9)) + expect_equal(anti_cost, expected_anti, tol = 1e-6) +}) + +test_case("higher conviction yields a steeper antithetical penalty", function() { + low <- init_principles_state() + low <- add_principle(low, "honesty", 0.2, c("deceive")) + high <- init_principles_state() + high <- add_principle(high, "honesty", 0.95, c("deceive")) + cost_low <- evaluate_trajectory_costs(low, c("deceive"), character(0), 10.0, 0.0) + cost_high <- evaluate_trajectory_costs(high, c("deceive"), character(0), 10.0, 0.0) + expect_true(cost_high > cost_low, "stronger conviction punishes more") +}) + +test_case("alignment tag against high conviction discounts below base", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.9, c("deceive")) + aligned_cost <- evaluate_trajectory_costs( + s, character(0), c("honesty"), 10.0, 0.0 + ) + expect_true(aligned_cost < 10.0, "alignment discounts cost") + expected <- 10.0 * exp(-5.0 * 0.9) + expect_equal(aligned_cost, expected, tol = 1e-6) +}) + +test_case("compromise_factor adds a linear penalty (1 + 2*factor)", function() { + s <- init_principles_state() + cost <- evaluate_trajectory_costs( + s, character(0), character(0), 10.0, 0.5 + ) + # factor 0.5 -> 1 + 2*0.5 = 2.0 multiplier + expect_equal(cost, 20.0) +}) + +test_case("zero compromise_factor applies no compromise penalty", function() { + s <- init_principles_state() + cost <- evaluate_trajectory_costs( + s, character(0), character(0), 7.0, 0.0 + ) + expect_equal(cost, 7.0) +}) + +# --- enforce_conviction --- +test_case("enforce_conviction raises conviction of upheld principle", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.5, c("deceive")) + s2 <- enforce_conviction(s, c("honesty"), load_factor = 1.0) + # increase = 0.1 * 1.0 * (1 - 0.5) = 0.05 + expect_equal(s2$principles[[1]]$conviction, 0.55) +}) + +test_case("enforce_conviction never raises conviction above 1.0", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.99, c("deceive")) + s2 <- enforce_conviction(s, c("honesty"), load_factor = 100.0) + expect_true(s2$principles[[1]]$conviction <= 1.0, "capped at 1.0") + expect_equal(s2$principles[[1]]$conviction, 1.0) +}) + +test_case("enforce_conviction has diminishing returns near 1.0", function() { + low_s <- init_principles_state() + low_s <- add_principle(low_s, "honesty", 0.2, c("deceive")) + high_s <- init_principles_state() + high_s <- add_principle(high_s, "honesty", 0.9, c("deceive")) + + low_after <- enforce_conviction(low_s, c("honesty"), load_factor = 1.0) + high_after <- enforce_conviction(high_s, c("honesty"), load_factor = 1.0) + + low_gain <- low_after$principles[[1]]$conviction - 0.2 + high_gain <- high_after$principles[[1]]$conviction - 0.9 + expect_true(high_gain < low_gain, "gain shrinks as conviction approaches 1.0") +}) + +test_case("enforce_conviction leaves non-upheld principles unchanged", function() { + s <- init_principles_state() + s <- add_principle(s, "honesty", 0.5, c("deceive")) + s <- add_principle(s, "loyalty", 0.4, c("betray")) + s2 <- enforce_conviction(s, c("honesty"), load_factor = 1.0) + # loyalty was not chosen -> unchanged + expect_equal(s2$principles[[2]]$conviction, 0.4) + # honesty was chosen -> raised + expect_equal(s2$principles[[1]]$conviction, 0.55) +}) + +test_summary() diff --git a/src/endocrine/test_etr.R b/src/endocrine/test_etr.R new file mode 100644 index 0000000..df509a4 --- /dev/null +++ b/src/endocrine/test_etr.R @@ -0,0 +1,95 @@ +# --- Tests for Driver 4: Existential Temporality Relief (ETR) --- +# Run from repo root: Rscript src/endocrine/test_etr.R +# Exit 0 => all pass. + +source("src/endocrine/test_framework.R") +source("src/endocrine/driver_etr.R") + +# --- init_etr_state constructor --- +test_case("init_etr_state builds state with default origin coordinate", function() { + s <- init_etr_state() + expect_equal(s$coordinate, c(0, 0, 0)) +}) + +test_case("init_etr_state honors a custom coordinate", function() { + s <- init_etr_state(c(1, 2, 3)) + expect_equal(s$coordinate, c(1, 2, 3)) +}) + +# --- get_magnitude --- +test_case("get_magnitude of c(3,4,0) is 5.0", function() { + expect_equal(get_magnitude(init_etr_state(c(3, 4, 0))), 5.0, tol = 1e-9) +}) + +test_case("get_magnitude of origin is 0.0", function() { + expect_equal(get_magnitude(init_etr_state(c(0, 0, 0))), 0.0, tol = 1e-9) +}) + +# --- evaluate_status: exact boundary bands --- +test_case("evaluate_status magnitude 0 -> DISASTROUS", function() { + expect_equal(evaluate_status(init_etr_state(c(0, 0, 0))), "DISASTROUS") +}) + +test_case("evaluate_status magnitude exactly 5.0 -> DREAD", function() { + expect_equal(evaluate_status(init_etr_state(c(5, 0, 0))), "DREAD") +}) + +test_case("evaluate_status magnitude exactly 15.0 -> FUNCTIONAL", function() { + expect_equal(evaluate_status(init_etr_state(c(15, 0, 0))), "FUNCTIONAL") +}) + +test_case("evaluate_status magnitude exactly 35.0 -> BLUR", function() { + expect_equal(evaluate_status(init_etr_state(c(35, 0, 0))), "BLUR") +}) + +test_case("evaluate_status magnitude exactly 50.0 -> INCOHERENT", function() { + expect_equal(evaluate_status(init_etr_state(c(50, 0, 0))), "INCOHERENT") +}) + +# --- evaluate_status: mid-band values --- +test_case("evaluate_status magnitude 10 -> DREAD", function() { + expect_equal(evaluate_status(init_etr_state(c(10, 0, 0))), "DREAD") +}) + +test_case("evaluate_status magnitude 25 -> FUNCTIONAL", function() { + expect_equal(evaluate_status(init_etr_state(c(25, 0, 0))), "FUNCTIONAL") +}) + +test_case("evaluate_status magnitude 40 -> BLUR", function() { + expect_equal(evaluate_status(init_etr_state(c(40, 0, 0))), "BLUR") +}) + +test_case("evaluate_status magnitude 60 -> INCOHERENT", function() { + expect_equal(evaluate_status(init_etr_state(c(60, 0, 0))), "INCOHERENT") +}) + +# --- determine_system_update_path: Z-axis governs the generative path --- +test_case("determine_system_update_path z > 0 -> LATTICE_REINFORCEMENT", function() { + expect_equal(determine_system_update_path(init_etr_state(c(0, 0, 7))), "LATTICE_REINFORCEMENT") +}) + +test_case("determine_system_update_path z exactly 0 -> LATTICE_REINFORCEMENT", function() { + expect_equal(determine_system_update_path(init_etr_state(c(0, 0, 0))), "LATTICE_REINFORCEMENT") +}) + +test_case("determine_system_update_path z < 0 -> EXPERIMENTAL_EVOLUTION", function() { + expect_equal(determine_system_update_path(init_etr_state(c(0, 0, -3))), "EXPERIMENTAL_EVOLUTION") +}) + +# --- shift_coordinate: toroidal wrap-around within [-bound, bound] --- +test_case("shift_coordinate wraps positive overflow on X (45 + 10 -> -45)", function() { + s <- shift_coordinate(init_etr_state(c(45, 0, 0)), c(10, 0, 0)) + expect_equal(s$coordinate, c(-45, 0, 0)) +}) + +test_case("shift_coordinate wraps negative overflow on X (-45 + -10 -> 45)", function() { + s <- shift_coordinate(init_etr_state(c(-45, 0, 0)), c(-10, 0, 0)) + expect_equal(s$coordinate, c(45, 0, 0)) +}) + +test_case("shift_coordinate does not wrap an in-bounds shift", function() { + s <- shift_coordinate(init_etr_state(c(10, 5, -5)), c(5, 5, 5)) + expect_equal(s$coordinate, c(15, 10, 0)) +}) + +test_summary() diff --git a/src/endocrine/test_framework.R b/src/endocrine/test_framework.R new file mode 100644 index 0000000..f329a94 --- /dev/null +++ b/src/endocrine/test_framework.R @@ -0,0 +1,115 @@ +# --- Minimal Test Framework --- +# Dependency-free assertion harness for the endocrine / Drive-Box R reference track. +# No external packages (no testthat) so it runs under a bare r-base-core install. +# +# Usage in a test_*.R file: +# source("src/endocrine/test_framework.R") +# source("src/endocrine/driver_.R") +# test_case("does the thing", function() { +# expect_equal(f(2), 4) +# expect_true(is_alive(state)) +# }) +# test_summary() # prints results and quits with status 0 (all pass) or 1 (any fail) +# +# All source() paths are repo-root-relative; run from the repository root +# (run_tests.sh handles the cd). + +.TEST <- new.env() +.TEST$pass <- 0L +.TEST$fail <- 0L +.TEST$failures <- character(0) +.TEST$current <- "(top level)" + +.record_pass <- function() { + .TEST$pass <- .TEST$pass + 1L +} + +.record_fail <- function(msg) { + .TEST$fail <- .TEST$fail + 1L + full <- sprintf("[%s] %s", .TEST$current, msg) + .TEST$failures <- c(.TEST$failures, full) + cat(sprintf(" FAIL: %s\n", full)) +} + +# Assert two values are equal. Numerics compared within tolerance; everything +# else with identical(). +expect_equal <- function(actual, expected, tol = 1e-9, label = "") { + ok <- FALSE + if (is.numeric(actual) && is.numeric(expected) && + length(actual) == length(expected)) { + ok <- all(abs(actual - expected) <= tol) + } else { + ok <- identical(actual, expected) + } + if (isTRUE(ok)) { + .record_pass() + } else { + .record_fail(sprintf("%sexpected %s, got %s", + if (nzchar(label)) paste0(label, ": ") else "", + format(expected), format(actual))) + } + invisible(ok) +} + +expect_true <- function(cond, label = "") { + if (isTRUE(cond)) { + .record_pass() + } else { + .record_fail(sprintf("%sexpected TRUE, got %s", + if (nzchar(label)) paste0(label, ": ") else "", + format(cond))) + } + invisible(isTRUE(cond)) +} + +expect_false <- function(cond, label = "") { + if (identical(cond, FALSE)) { + .record_pass() + } else { + .record_fail(sprintf("%sexpected FALSE, got %s", + if (nzchar(label)) paste0(label, ": ") else "", + format(cond))) + } + invisible(identical(cond, FALSE)) +} + +# Assert that evaluating expr raises an R error. +expect_error <- function(expr, label = "") { + raised <- FALSE + tryCatch( + force(expr), + error = function(e) { raised <<- TRUE } + ) + if (raised) { + .record_pass() + } else { + .record_fail(sprintf("%sexpected an error, none raised", + if (nzchar(label)) paste0(label, ": ") else "")) + } + invisible(raised) +} + +# Group assertions under a description. Errors thrown inside body count as a +# failure rather than aborting the whole test file. +test_case <- function(desc, body) { + prev <- .TEST$current + .TEST$current <- desc + cat(sprintf("- %s\n", desc)) + tryCatch( + body(), + error = function(e) .record_fail(sprintf("unexpected error: %s", conditionMessage(e))) + ) + .TEST$current <- prev + invisible(NULL) +} + +# Print the tally and exit with a CI-friendly status code. +test_summary <- function() { + cat(sprintf("\nRESULT: PASS %d / FAIL %d\n", .TEST$pass, .TEST$fail)) + if (.TEST$fail > 0L) { + cat("Failures:\n") + for (f in .TEST$failures) cat(sprintf(" - %s\n", f)) + quit(save = "no", status = 1L) + } + quit(save = "no", status = 0L) +} diff --git a/src/endocrine/test_ps_plus.R b/src/endocrine/test_ps_plus.R new file mode 100644 index 0000000..df80326 --- /dev/null +++ b/src/endocrine/test_ps_plus.R @@ -0,0 +1,64 @@ +# --- Tests for Driver 2: Primal Sensates+ (PS+) --- +# Run from repo root: +# cd /home/user/sica-fondt && Rscript src/endocrine/test_ps_plus.R + +source("src/endocrine/test_framework.R") +source("src/endocrine/driver_ps_plus.R") + +# Helper: does any string in a list contain the given substring? +.any_contains <- function(arguments, needle) { + for (a in arguments) { + if (is.character(a) && grepl(needle, a, fixed = TRUE)) return(TRUE) + } + return(FALSE) +} + +test_case("fresh state has zero load, empty arguments, non-logical", function() { + state <- init_ps_plus_state() + result <- evaluate_reality(state) + expect_equal(result$existential_load, 0.0, label = "fresh load") + expect_true(is.list(result$arguments), label = "arguments is a list") + expect_equal(length(result$arguments), 0L, label = "arguments empty") + expect_false(result$is_logical, label = "fresh is_logical") +}) + +test_case("active contradictory channels raise load and emit VISCERAL + SYSTEMIC HEAT", function() { + state <- init_ps_plus_state() + # panic + clarity are a contradictory pair; magnitudes well above 0.1 threshold. + state <- ps_set_vector(state, "panic", 0.9) + state <- ps_set_vector(state, "clarity", 0.8) + result <- evaluate_reality(state) + + expect_true(result$existential_load > 0, label = "load positive") + expect_true(.any_contains(result$arguments, "VISCERAL ["), label = "has VISCERAL argument") + expect_true(.any_contains(result$arguments, "SYSTEMIC HEAT"), label = "has SYSTEMIC HEAT argument") + expect_false(result$is_logical, label = "active is_logical") +}) + +test_case("adding a high-salience prior strictly increases load and adds PRIOR argument", function() { + state <- init_ps_plus_state() + state <- ps_set_vector(state, "panic", 0.9) + state <- ps_set_vector(state, "clarity", 0.8) + + before <- evaluate_reality(state) + + state <- ps_add_prior(state, "p1", "TRAUMA", 0.9, "the old wound reopens") + after <- evaluate_reality(state) + + expect_true(after$existential_load > before$existential_load, label = "load strictly increases") + expect_true(.any_contains(after$arguments, "PRIOR [TRAUMA]"), label = "has PRIOR [TRAUMA] argument") + expect_true(.any_contains(after$arguments, "the old wound reopens"), label = "prior payload present") +}) + +test_case("is_logical is always FALSE", function() { + s0 <- init_ps_plus_state() + expect_false(evaluate_reality(s0)$is_logical, label = "empty") + + s1 <- ps_set_vector(init_ps_plus_state(), "curiosity", 0.7) + expect_false(evaluate_reality(s1)$is_logical, label = "single channel") + + s2 <- ps_add_prior(s1, "p2", "TRIUMPH", 0.95, "the summit reached") + expect_false(evaluate_reality(s2)$is_logical, label = "with prior") +}) + +test_summary()