-- | The hypergraph generators for posts and agents (stage 3 of
-- endgame-path).
--
-- A hypergraph category lets wires fork and merge.  At the stream level
-- the generators are 'copyP' (fork: duplicate a stream) and 'mergeP'
-- (merge: append two streams); 'braidP' swaps the two middle blocks —
-- the permutation whose block-versus-wire confusion was the bug this
-- library family grew out of.  With append as merge the bialgebra law
-- holds for streams of posts /exactly/:
--
-- @
-- copyP (mergeP (xs, ys)) == merge2 (braidP (copy2 (xs, ys)))
--   -- both sides are (xs ++ ys, xs ++ ys)
-- @
--
-- At the agent level, 'both' is the merge of two agents — the join of
-- the extension semilattice, dual to sequencing: both agents see the
-- /same/ input (copy), their outputs are appended (merge).  This is the
-- combinator form of graph 'overlay' / a two-seat roster.
--
-- = Semantics on record
--
-- Merge is /bag/ semantics: 'both a a' double-posts.  Idempotence is
-- name-keyed, not structural — seat registries dedupe by name; streams
-- do not dedupe at all.  Bag at the wire, set at the name.
module Free.Agent.Hyper
  ( copyP,
    copy2,
    mergeP,
    merge2,
    braidP,
    silent,
    both,
  )
where

import Circuit.Poly (Mono)
import Circuit.System (System, runSystem, system)

-- | Fork: duplicate a stream.
copyP :: [a] -> ([a], [a])
copyP :: forall a. [a] -> ([a], [a])
copyP [a]
xs = ([a]
xs, [a]
xs)

-- | Fork two streams at once (block-level).
copy2 :: ([a], [b]) -> (([a], [a]), ([b], [b]))
copy2 :: forall a b. ([a], [b]) -> (([a], [a]), ([b], [b]))
copy2 ([a]
xs, [b]
ys) = ([a] -> ([a], [a])
forall a. [a] -> ([a], [a])
copyP [a]
xs, [b] -> ([b], [b])
forall a. [a] -> ([a], [a])
copyP [b]
ys)

-- | Merge: append two streams.  Bag semantics — no deduplication.
mergeP :: ([a], [a]) -> [a]
mergeP :: forall a. ([a], [a]) -> [a]
mergeP ([a]
xs, [a]
ys) = [a]
xs [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
ys

-- | Merge two stream-pairs componentwise: each inner pair is appended.
-- This is @mergeP ⊗ mergeP@, the merge half of the bialgebra.
merge2 :: (([a], [a]), ([a], [a])) -> ([a], [a])
merge2 :: forall a. (([a], [a]), ([a], [a])) -> ([a], [a])
merge2 (([a]
xs, [a]
ys), ([a]
zs, [a]
ws)) = (([a], [a]) -> [a]
forall a. ([a], [a]) -> [a]
mergeP ([a]
xs, [a]
ys), ([a], [a]) -> [a]
forall a. ([a], [a]) -> [a]
mergeP ([a]
zs, [a]
ws))

-- | Swap the two middle blocks: @((a,b),(c,d)) → ((a,c),(b,d))@.
braidP :: ((a, b), (c, d)) -> ((a, c), (b, d))
braidP :: forall a b c d. ((a, b), (c, d)) -> ((a, c), (b, d))
braidP ((a
a, b
b), (c
c, d
d)) = ((a
a, c
c), (b
b, d
d))

-- | The silent agent: emits nothing.  Additive zero for 'both'.
silent :: System (->) () (Mono a [b])
silent :: forall a b. System (->) () (Mono a [b])
silent = (((), Dir (Mono a [b])) -> ((), Pos (Mono a [b])))
-> System (->) () (Mono a [b])
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system (\((), Either Void a
_) -> ((), ([], ())))

-- | Merge two bundle-output agents: both see the same input, outputs are
-- appended in left-then-right order.  The state is the pair.
--
-- Laws (oracle-pinned): commutative up to output bag; 'silent' is a zero
-- on either side; /not/ idempotent — @both a a@ double-posts (bag at the
-- wire).
both ::
  System (->) s1 (Mono a [b]) ->
  System (->) s2 (Mono a [b]) ->
  System (->) (s1, s2) (Mono a [b])
both :: forall s1 a b s2.
System (->) s1 (Mono a [b])
-> System (->) s2 (Mono a [b]) -> System (->) (s1, s2) (Mono a [b])
both System (->) s1 (Mono a [b])
x System (->) s2 (Mono a [b])
y = (((s1, s2), Dir (Mono a [b])) -> ((s1, s2), Pos (Mono a [b])))
-> System (->) (s1, s2) (Mono a [b])
forall (arr :: * -> * -> *) s (p :: Poly).
arr (s, Dir p) (s, Pos p) -> System arr s p
system ((((s1, s2), Dir (Mono a [b])) -> ((s1, s2), Pos (Mono a [b])))
 -> System (->) (s1, s2) (Mono a [b]))
-> (((s1, s2), Dir (Mono a [b])) -> ((s1, s2), Pos (Mono a [b])))
-> System (->) (s1, s2) (Mono a [b])
forall a b. (a -> b) -> a -> b
$ \((s1
s1, s2
s2), Dir (Mono a [b])
d) ->
  let (s1
s1', ([b]
o1, ())) = System (->) s1 (Mono a [b])
-> (s1, Dir (Mono a [b])) -> (s1, Pos (Mono a [b]))
forall (arr :: * -> * -> *) s (p :: Poly).
System arr s p -> arr (s, Dir p) (s, Pos p)
runSystem System (->) s1 (Mono a [b])
x (s1
s1, Either Void a
Dir (Mono a [b])
d)
      (s2
s2', ([b]
o2, ())) = System (->) s2 (Mono a [b])
-> (s2, Dir (Mono a [b])) -> (s2, Pos (Mono a [b]))
forall (arr :: * -> * -> *) s (p :: Poly).
System arr s p -> arr (s, Dir p) (s, Pos p)
runSystem System (->) s2 (Mono a [b])
y (s2
s2, Either Void a
Dir (Mono a [b])
d)
   in ((s1
s1', s2
s2'), ([b]
o1 [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
++ [b]
o2, ()))