{-# LANGUAGE OverloadedStrings #-}

-- | Semiring delivery matrices for addressed posts.
--
-- 'deliversTo' in 'Circuit.Agent' is the boolean predicate that gates delivery.
-- This module lifts the same logic to an arbitrary 'NumHask' semiring,
-- producing delivery and topology matrices that can be interpreted under
-- different semirings:
--
-- * Boolean: exactly today's discrete delivery (the regression fence, G2).
-- * Real / probability: weighted delivery for gradient-based routing.
-- * Path-counting: number of delivery paths (useful for G3).
--
-- A post delivers to a recipient when the recipient appears in the post's 'to'
-- list.  The 'from' field is treated as the sender when building agent-to-agent
-- topology matrices.
module Circuit.Agent.Delivery
  ( -- * Semiring predicate
    deliversToSemiring,

    -- * Finite-relation delivery model
    DelRel,
    copyRel,
    discardRel,
    broadcastRel,
    emptyRel,
    namedRel,
    deliveryRel,
    deliversRel,

    -- * Matrices
    deliveryMatrix,
    topologyMatrix,

    -- * Nilpotency / acyclicity check
    isNilpotent,
    matrixPowers,
  )
where

import Circuit.Mat.Dense (Matrix (..), fromLists, matTimes, toLists)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text, empty)
import Data.Vector.Unboxed qualified as VU
import Harpie.Array qualified as A
import NumHask.Algebra.Additive (Additive (..))
import NumHask.Algebra.Multiplicative (Multiplicative (..))
import Prelude hiding ((*), (+))

-- | Semiring-generalised delivery predicate.
--
-- A post delivers with the semiring's 'one' when @who@ is in the recipient
-- list, or when the recipient list contains the broadcast sentinel @"all"@;
-- @[]@ and @[""]@ are discard (deliver to no one).  Otherwise it delivers
-- with 'zero'.
deliversToSemiring ::
  (Additive r, Multiplicative r) =>
  -- | Recipients on the post.
  [Text] ->
  -- | Recipient name.
  Text ->
  r
deliversToSemiring :: forall r. (Additive r, Multiplicative r) => [Text] -> Text -> r
deliversToSemiring [Text]
recipients Text
who
  | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
recipients = r
forall a. Additive a => a
zero
  | [Text]
recipients [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
empty] = r
forall a. Additive a => a
zero
  | (Text
"all" :: Text) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
recipients = r
forall a. Multiplicative a => a
one
  | Text
who Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
recipients = r
forall a. Multiplicative a => a
one
  | Bool
otherwise = r
forall a. Additive a => a
zero

-- ===========================================================================
-- Finite-relation delivery model
-- ===========================================================================

-- | A relation from a single post (the unit type) to a finite set of agents.
--
-- This is the set-based reading of FinRel: objects are finite sets, morphisms
-- are relations, and the cartesian comonoid on the agent set gives canonical
-- copy/discard generators.  The @\"all\"@ broadcast sentinel is the dagger
-- (relational converse) of 'discardRel'; the empty / @[\"\"]@ case is the zero
-- morphism 'emptyRel'.
type DelRel a = Set ((), a)

-- | Canonical copy comonoid on a finite agent set.
--
-- Relates each agent @a@ to the pair @(a, a)@.
copyRel :: Set a -> Set (a, (a, a))
copyRel :: forall a. Set a -> Set (a, (a, a))
copyRel Set a
agents = (a -> (a, (a, a))) -> Set a -> Set (a, (a, a))
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (\a
a -> (a
a, (a
a, a
a))) Set a
agents

-- | Canonical discard counit on a finite agent set.
--
-- Relates every agent to the terminal value @()@.
discardRel :: Set a -> Set (a, ())
discardRel :: forall a. Set a -> Set (a, ())
discardRel Set a
agents = (a -> (a, ())) -> Set a -> Set (a, ())
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic (\a
a -> (a
a, ())) Set a
agents

-- | Broadcast relation: the dagger of 'discardRel'.
--
-- Maps the single post @()@ to every agent in the roster.  This is exactly
-- the semantics of @to = [\"all\"]@.
broadcastRel :: Set a -> DelRel a
broadcastRel :: forall a. Set a -> DelRel a
broadcastRel Set a
agents = (a -> ((), a)) -> Set a -> Set ((), a)
forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic ((),) Set a
agents

-- | Empty (zero) delivery relation.
--
-- This is the semantics of @to = []@ and @to = [\"\"]@: the post reaches no
-- agent.
emptyRel :: DelRel a
emptyRel :: forall a. DelRel a
emptyRel = Set ((), a)
forall a. Set a
Set.empty

-- | Singleton injection for a named recipient.
namedRel :: a -> DelRel a
namedRel :: forall a. a -> DelRel a
namedRel a
a = ((), a) -> Set ((), a)
forall a. a -> Set a
Set.singleton ((), a
a)

-- | Delivery relation encoded by a post's @to@ list.
--
-- * @\"all\"@ selects the broadcast relation ('broadcastRel').
-- * @[]@ and @[\"\"]@ select the zero relation ('emptyRel').
-- * Named recipients select the corresponding singleton injections.
deliveryRel ::
  -- | Roster of agents (the codomain of the relation).
  Set Text ->
  -- | Recipients on the post.
  [Text] ->
  DelRel Text
deliveryRel :: Set Text -> [Text] -> DelRel Text
deliveryRel Set Text
agents [Text]
tos
  | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
tos = DelRel Text
forall a. DelRel a
emptyRel
  | [Text]
tos [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
empty] = DelRel Text
forall a. DelRel a
emptyRel
  | (Text
"all" :: Text) Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
tos = Set Text -> DelRel Text
forall a. Set a -> DelRel a
broadcastRel Set Text
agents
  | Bool
otherwise = [((), Text)] -> DelRel Text
forall a. Ord a => [a] -> Set a
Set.fromList [((), Text
a) | Text
a <- [Text]
tos]

-- | Evaluate a delivery relation against a subscriber set.
--
-- Returns 'True' when the relation's image intersects the subscribers.
deliversRel :: DelRel Text -> Set Text -> Bool
deliversRel :: DelRel Text -> Set Text -> Bool
deliversRel DelRel Text
rel Set Text
subs = Bool -> Bool
not (Set Text -> Bool
forall a. Set a -> Bool
Set.null (Set Text
image Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` Set Text
subs))
  where
    image :: Set Text
image = (((), Text) -> Text) -> DelRel Text -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map ((), Text) -> Text
forall a b. (a, b) -> b
snd DelRel Text
rel

-- | Delivery matrix for a fixed list of posts and a roster of agents.
--
-- Rows are posts (in the order given), columns are agents (in the order
-- given), and entry @(p, a)@ is the delivery weight of post @p@ to agent @a@.
deliveryMatrix ::
  (Additive r, Multiplicative r) =>
  -- | Agents (column labels).
  [Text] ->
  -- | Recipient lists for each post (row labels are implicit).
  [[Text]] ->
  Matrix r
deliveryMatrix :: forall r.
(Additive r, Multiplicative r) =>
[Text] -> [[Text]] -> Matrix r
deliveryMatrix [Text]
agents [[Text]]
recipients =
  [[r]] -> Matrix r
forall a. [[a]] -> Matrix a
fromLists [(Text -> r) -> [Text] -> [r]
forall a b. (a -> b) -> [a] -> [b]
map ([Text] -> Text -> r
forall r. (Additive r, Multiplicative r) => [Text] -> Text -> r
deliversToSemiring [Text]
recips) [Text]
agents | [Text]
recips <- [[Text]]
recipients]

-- | Agent-to-agent delivery topology matrix.
--
-- Rows and columns are agents.  Entry @(i, j)@ is the combined weight with
-- which agent @i@'s authored posts are delivered to agent @j@.  The
-- aggregation uses the semiring addition ('+'), so multiple posts from the
-- same sender to the same recipient accumulate.
--
-- Posts are given as @(author, recipients)@ pairs.
topologyMatrix ::
  (Additive r, Multiplicative r) =>
  -- | Agents (row and column labels, in the same order).
  [Text] ->
  -- | Posts as @(author, recipients)@ pairs.
  [(Text, [Text])] ->
  Matrix r
topologyMatrix :: forall r.
(Additive r, Multiplicative r) =>
[Text] -> [(Text, [Text])] -> Matrix r
topologyMatrix [Text]
agents [(Text, [Text])]
posts =
  [[r]] -> Matrix r
forall a. [[a]] -> Matrix a
fromLists
    [ [ [r] -> r
forall {t}. Additive t => [t] -> t
sum' [[Text] -> Text -> r
forall r. (Additive r, Multiplicative r) => [Text] -> Text -> r
deliversToSemiring [Text]
recipients Text
who | (Text
whoFrom, [Text]
recipients) <- [(Text, [Text])]
posts, Text
whoFrom Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
fromAgent]
      | Text
who <- [Text]
agents
      ]
    | Text
fromAgent <- [Text]
agents
    ]
  where
    sum' :: [t] -> t
sum' [] = t
forall a. Additive a => a
zero
    sum' (t
x : [t]
xs) = t
x t -> t -> t
forall a. Additive a => a -> a -> a
+ [t] -> t
sum' [t]
xs

-- | Powers of a square matrix, starting from the first power.
matrixPowers ::
  (Additive r, Multiplicative r) =>
  Int ->
  Matrix r ->
  [Matrix r]
matrixPowers :: forall r.
(Additive r, Multiplicative r) =>
Int -> Matrix r -> [Matrix r]
matrixPowers Int
n Matrix r
m = Int -> [Matrix r] -> [Matrix r]
forall a. Int -> [a] -> [a]
take Int
n ((Matrix r -> Matrix r) -> Matrix r -> [Matrix r]
forall a. (a -> a) -> a -> [a]
iterate (Matrix r -> Matrix r -> Matrix r
forall a.
(Additive a, Multiplicative a) =>
Matrix a -> Matrix a -> Matrix a
matTimes Matrix r
m) Matrix r
m)

-- | A square matrix is nilpotent when some power is the zero matrix.
--
-- For a delivery topology, nilpotency means the communication graph is a DAG:
-- no directed cycle can return a non-zero weight, so every sufficiently long
-- path multiplies out to zero.
isNilpotent ::
  (Additive r, Multiplicative r, Eq r) =>
  Matrix r ->
  Bool
isNilpotent :: forall r. (Additive r, Multiplicative r, Eq r) => Matrix r -> Bool
isNilpotent Matrix r
m = (Matrix r -> Bool) -> [Matrix r] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Matrix r -> Bool
isZeroMatrix (Int -> Matrix r -> [Matrix r]
forall r.
(Additive r, Multiplicative r) =>
Int -> Matrix r -> [Matrix r]
matrixPowers (Matrix r -> Int
forall {a}. Matrix a -> Int
rows Matrix r
m) Matrix r
m)
  where
    rows :: Matrix a -> Int
rows (Matrix Array a
a) = case Vector Int -> [Int]
forall a. Unbox a => Vector a -> [a]
VU.toList (Array a -> Vector Int
forall a. Array a -> Vector Int
A.shape Array a
a) of
      (Int
r : [Int]
_) -> Int
r
      [Int]
_ -> Int
0
    isZeroMatrix :: Matrix r -> Bool
isZeroMatrix = ([r] -> Bool) -> [[r]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((r -> Bool) -> [r] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
forall a. Additive a => a
zero)) ([[r]] -> Bool) -> (Matrix r -> [[r]]) -> Matrix r -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Matrix r -> [[r]]
forall a. Matrix a -> [[a]]
toLists