diff --git a/src/Core/Veridicality.fs b/src/Core/Veridicality.fs index 3985100e..c29a94ee 100644 --- a/src/Core/Veridicality.fs +++ b/src/Core/Veridicality.fs @@ -195,3 +195,48 @@ module Veridicality = | None -> [] Map.add key (c :: existing) acc) Map.empty |> Map.map (fun _ xs -> List.rev xs) + + /// **Anti-consensus gate** — claims supporting the same + /// assertion must come from at least TWO independent + /// `RootAuthority` values before they're allowed to upgrade + /// trust. Returns `Ok claims` when the set of distinct + /// non-empty root authorities across the input has + /// cardinality >= 2; `Error msg` otherwise. + /// + /// Operational intent: if 50 claims all assert the same + /// fact but they all trace back to a single upstream source, + /// the 50-way agreement is a single piece of evidence, not + /// 50 independent pieces. The gate rejects pseudo-consensus; + /// genuine multi-root agreement passes. + /// + /// The input list is assumed to already be ABOUT the same + /// assertion (callers group-by canonical claim key before + /// invoking). The gate does NOT canonicalize; that's the + /// `canonicalKey` / `groupByCanonical` pair's job. + /// + /// **Degenerate-root filter.** Empty / whitespace-only + /// `RootAuthority` values are dropped before counting — + /// they do not count as a distinct root. This matches the + /// tolerant-skip convention of the module's other + /// primitives (degenerate input is skipped rather than + /// throwing). Callers that want strict validation should + /// run `validateProvenance` first. + /// + /// Edge cases: + /// * Empty list — zero roots, fails the gate. + /// * Single-claim list — one root, fails. + /// * Duplicate-root lists — fails unless a distinct alternate + /// root also appears. + /// * Lists whose only "second root" is empty/whitespace — + /// fails (empty root does not count). + let antiConsensusGate (claims: Claim<'T> list) : Result list, string> = + let agreeingRoots = + claims + |> List.map (fun c -> c.Prov.RootAuthority) + |> List.filter (fun r -> not (String.IsNullOrWhiteSpace r)) + |> Set.ofList + |> Set.count + if agreeingRoots < 2 then + Error "Agreement without independent roots" + else + Ok claims diff --git a/tests/Tests.FSharp/Algebra/Veridicality.Tests.fs b/tests/Tests.FSharp/Algebra/Veridicality.Tests.fs index 2e076a91..6858b55c 100644 --- a/tests/Tests.FSharp/Algebra/Veridicality.Tests.fs +++ b/tests/Tests.FSharp/Algebra/Veridicality.Tests.fs @@ -186,3 +186,101 @@ let ``groupByCanonical produces distinct-root counts per bucket`` () = bucket |> List.map (fun c -> c.Prov.RootAuthority) |> Set.ofList |> Set.count distinctRoots grouped.[xKey] |> should equal 2 distinctRoots grouped.[yKey] |> should equal 1 + + +// ─── antiConsensusGate ───────── + +let private claimWithRoot (id: string) (root: string) : Veridicality.Claim = + { Id = id + Payload = 0 + Weight = 1L + Prov = { goodProv () with RootAuthority = root } } + +[] +let ``antiConsensusGate rejects empty list`` () = + match Veridicality.antiConsensusGate [] with + | Error _ -> () + | Ok _ -> failwith "expected Error for empty list" + +[] +let ``antiConsensusGate rejects a single-claim list`` () = + let claims = [ claimWithRoot "c1" "root-a" ] + match Veridicality.antiConsensusGate claims with + | Error _ -> () + | Ok _ -> failwith "expected Error for single claim" + +[] +let ``antiConsensusGate rejects many claims from a single root`` () = + // 50-way agreement from one root is still one piece of + // evidence, not 50. + let claims = + [ for i in 1 .. 50 -> claimWithRoot $"c{i}" "root-a" ] + match Veridicality.antiConsensusGate claims with + | Error msg -> msg.Contains("independent") |> should equal true + | Ok _ -> failwith "expected Error for same-root cluster" + +[] +let ``antiConsensusGate accepts two claims from two distinct roots`` () = + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" "root-b" ] + match Veridicality.antiConsensusGate claims with + | Ok returned -> returned |> should equal claims + | Error msg -> failwith $"expected Ok, got Error: {msg}" + +[] +let ``antiConsensusGate accepts many claims spanning multiple roots`` () = + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" "root-a" + claimWithRoot "c3" "root-b" + claimWithRoot "c4" "root-c" ] + match Veridicality.antiConsensusGate claims with + | Ok _ -> () + | Error msg -> failwith $"expected Ok, got Error: {msg}" + +[] +let ``antiConsensusGate returns Ok with the original list unchanged on pass`` () = + // Gate is read-only: it returns the same list it was given. + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" "root-b" ] + match Veridicality.antiConsensusGate claims with + | Ok returned -> returned |> List.length |> should equal 2 + | Error msg -> failwith msg + +[] +let ``antiConsensusGate does NOT count empty RootAuthority as a distinct root`` () = + // Degenerate/missing RootAuthority values must be filtered + // before counting distinct roots — otherwise an empty string + // would inflate the anti-consensus count and let a single- + // source cluster pass the gate. + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" "" ] + match Veridicality.antiConsensusGate claims with + | Error _ -> () + | Ok _ -> failwith "expected Error when the only 'second root' is empty" + +[] +let ``antiConsensusGate does NOT count whitespace RootAuthority as a distinct root`` () = + // Whitespace-only RootAuthority values are treated the same + // as empty — they don't count toward the distinct-root total. + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" " " ] + match Veridicality.antiConsensusGate claims with + | Error _ -> () + | Ok _ -> failwith "expected Error when the only 'second root' is whitespace" + +[] +let ``antiConsensusGate skips empty RootAuthority but still passes on two valid roots`` () = + // Empty-root claims are silently skipped; remaining valid + // roots are counted. Two valid distinct roots → pass. + let claims = + [ claimWithRoot "c1" "root-a" + claimWithRoot "c2" "" + claimWithRoot "c3" "root-b" ] + match Veridicality.antiConsensusGate claims with + | Ok _ -> () + | Error msg -> failwith $"expected Ok (two valid distinct roots), got Error: {msg}"