| NB. ============================================================================= |
| NB. Foundry F1 β Emission Gate + CSL checks (PURE J) |
| NB. Copyright (C) 2026 Foundry / Prime Materia Commons |
| NB. |
| NB. This program is free software: you can redistribute it and/or modify |
| NB. it under the terms of the GNU Affero General Public License as published |
| NB. by the Free Software Foundation, either version 3 of the License, or |
| NB. (at your option) any later version. |
| NB. |
| NB. This program is distributed in the hope that it will be useful, |
| NB. but WITHOUT ANY WARRANTY; without even the implied warranty of |
| NB. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| NB. GNU Affero General Public License for more details. |
| NB. |
| NB. You should have received a copy of the GNU Affero General Public License |
| NB. along with this program. If not, see <https://www.gnu.org/licenses/>. |
| NB. ============================================================================= |
| NB. |
| NB. Contract: spec/J_API.md Β§ Emission/CSL; PROPERTIES Β§H (48β52). |
| NB. Verbs: emit_apply csl_neutrality csl_beneficence csl_commutation |
| NB. Verdicts: CSL_PASS CSL_FAIL_NEUTRALITY CSL_FAIL_BENEFICENCE CSL_FAIL_COMMUTATION |
| NB. Policies: GP_PASSTHROUGH GP_SUPPRESS GP_HOLD GP_ATTENUATE (types.ijs) |
|
|
| cocurrent 'foundry' |
|
|
| NB. ββ emit_apply ββββββββββββββββββββββββββββββββββββββββββββββββββββββββββββββ |
| NB. out emit_apply (prev ; q ; policy ; epsilon) |
| NB. PassThrough: out |
| NB. Suppress: zeros if q >= 1-Ξ΅ else out (PROPERTIES 48) |
| NB. Hold: prev if q >= 1-Ξ΅ else out |
| NB. Attenuate: out * max(0, (1-Ξ΅)-q) NB. parens: J is RTL (PROPERTIES 49) |
| emit_apply =: 4 : 0 |
| out =. , x |
| y =. boxxopen y |
| prev =. , > 0 { y |
| q =. 0 ". ": > 1 { y |
| pol =. 0 ". ": > 2 { y |
| eps =. 0 ". ": > 3 { y , <0.1 |
| select. pol |
| case. GP_PASSTHROUGH do. out |
| case. GP_SUPPRESS do. |
| if. q >: 1 - eps do. (# out) $ 0. else. out end. |
| case. GP_HOLD do. |
| if. q >: 1 - eps do. prev else. out end. |
| case. GP_ATTENUATE do. |
| scale =. 0 >. (1 - eps) - q |
| out * scale |
| case. do. out |
| end. |
| ) |
|
|
| NB. ββ csl_neutrality ββββββββββββββββββββββββββββββββββββββββββββββββββββββββββ |
| NB. x csl_neutrality (Tx ; epsilon) |
| NB. Fail if |xi-xj|>1e_15 and |Ti-Tj|/|xi-xj| > 1+Ξ΅ (PROPERTIES 50) |
| csl_neutrality =: 4 : 0 |
| xv =. , x |
| y =. boxxopen y |
| Tx =. , > 0 { y |
| eps =. 0 ". ": > 1 { y , <0.1 |
| n =. # xv |
| verdict =. CSL_PASS |
| for_i. i. n do. |
| for_j. (i + 1) + i. 0 >. (n - i) - 1 do. |
| dx =. | (i { xv) - j { xv |
| dT =. | (i { Tx) - j { Tx |
| if. (dx > 1e_15) *. ((dT % dx) > 1 + eps) do. |
| verdict =. CSL_FAIL_NEUTRALITY |
| end. |
| end. |
| end. |
| verdict |
| ) |
|
|
| NB. ββ csl_beneficence βββββββββββββββββββββββββββββββββββββββββββββββββββββββββ |
| NB. x csl_beneficence (Tx ; residual ; epsilon) |
| NB. βT(x)β_2 β€ (1+Ξ΅)βxβ_2 and residual β€ (1+Ξ΅)βxβ_2 (PROPERTIES 51) |
| csl_beneficence =: 4 : 0 |
| xv =. , x |
| y =. boxxopen y |
| Tx =. , > 0 { y |
| resid =. 0 ". ": > 1 { y |
| eps =. 0 ". ": > 2 { y , <0.1 |
| norm_x =. %: xv +/ . * xv |
| norm_Tx =. %: Tx +/ . * Tx |
| if. (norm_x > 1e_15) *. (norm_Tx > (1 + eps) * norm_x) do. |
| CSL_FAIL_BENEFICENCE return. |
| end. |
| if. resid > (1 + eps) * norm_x do. |
| CSL_FAIL_BENEFICENCE return. |
| end. |
| CSL_PASS |
| ) |
|
|
| NB. ββ csl_commutation βββββββββββββββββββββββββββββββββββββββββββββββββββββββββ |
| NB. x csl_commutation (T_hook ; filter_hook ; epsilon) |
| NB. βfilter(T(x)) - T(filter(x))β_β β€ Ξ΅ (PROPERTIES 52) |
| csl_commutation =: 4 : 0 |
| xv =. , x |
| y =. boxxopen y |
| Th =. 0 { y |
| Fh =. 1 { y |
| eps =. 0 ". ": > 2 { y , <0.1 |
| Tx =. xv apply_hook Th |
| fTx =. Tx apply_hook Fh |
| fx =. xv apply_hook Fh |
| Tfx =. fx apply_hook Th |
| if. +./ eps < | fTx - Tfx do. CSL_FAIL_COMMUTATION else. CSL_PASS end. |
| ) |
|
|
| cocurrent 'base' |
|
|
