-- | Mermaid printer for the string-diagram skeleton.
--
-- Test-only pin: emit an 'SDiagram' as a mermaid @flowchart@ so diagrams
-- render anywhere markdown does (org/emacs, GitHub), before any chart-svg
-- layout work.  The printer consumes the hypergraph normal form ("Circuit.Diagram.Hyper"), so spiders and swaps vanish into
-- port connectivity and structural laws show up as plain edges — a
-- copy-then-merge round trip prints as a single wire.
--
-- Design notes:
--
-- * One mermaid node per 'HyperNode'; structural constructors print as
--   symbols (@∪@, @∩@, @λ@, @α@, …).
-- * Boundary ports print as stadium nodes @in N@ / @out N@.
-- * A wire class with several producers or consumers fans out into one
--   mermaid edge per producer–consumer pair.
-- * Edges carry port labels only when a node endpoint has arity greater
--   than one.
-- * 'STurn' swaps node input/output arities, toggles a @†@ suffix on
--   labels, and reverses boundary order; node identity is by label, as in
--   the hypergraph normal form: two boxes with the same label collapse to
--   one mermaid node.
module Circuit.Mermaid
  ( toMermaid,
  )
where

import Circuit.Diagram (SDiagram)
import Circuit.Diagram.Hyper
  ( BoundaryEnd (..),
    HyperGraph (..),
    HyperNode (..),
    PortDir (..),
    PortEnd (..),
    Wire (..),
    normalise,
  )
import Data.List (nub)
import Prelude

-- $setup
-- >>> import Circuit.Mermaid
-- >>> import Circuit.Poly.StringDiagram

-- | Print a diagram skeleton as a mermaid flowchart.
--
-- >>> putStr (toMermaid (SThenD (SBox "f" 1 1) (SBox "g" 1 1)))
-- flowchart LR
--   in0(["in 0"])
--   out0(["out 0"])
--   n0["f"]
--   n1["g"]
--   n0 --> n1
--   in0 --> n0
--   n1 --> out0
--
-- Spiders are connectivity, so copy-then-merge is a single wire:
--
-- >>> putStr (toMermaid (SThenD sCopy sMerge))
-- flowchart LR
--   in0(["in 0"])
--   out0(["out 0"])
--   in0 --> out0
--
-- A cup is a two-input symbol node with labelled ports:
--
-- >>> putStr (toMermaid SBend)
-- flowchart LR
--   in0(["in 0"])
--   in1(["in 1"])
--   n0["∪"]
--   in0 -->|i0| n0
--   in1 -->|i1| n0
--
-- A trace hides the last input/output pair as a feedback loop:
--
-- >>> putStr (toMermaid (STrace (SBox "f" 2 2)))
-- flowchart LR
--   in0(["in 0"])
--   out0(["out 0"])
--   n0["f"]
--   n0 -->|o1:i1| n0
--   in0 -->|i0| n0
--   n0 -->|o0| out0
toMermaid :: SDiagram -> String
toMermaid :: SDiagram -> String
toMermaid = HyperGraph -> String
render (HyperGraph -> String)
-> (SDiagram -> HyperGraph) -> SDiagram -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SDiagram -> HyperGraph
normalise

-- Print a hypergraph normal form as a mermaid flowchart.
render :: HyperGraph -> String
render :: HyperGraph -> String
render HyperGraph
hg =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [String
"flowchart LR"]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> String
forall {a}. Show a => a -> String
inDecl [Int
0 .. HyperGraph -> Int
hgInArity HyperGraph
hg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> String
forall {a}. Show a => a -> String
outDecl [Int
0 .. HyperGraph -> Int
hgOutArity HyperGraph
hg Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (HyperNode -> String) -> [HyperNode] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HyperNode -> String
nodeDecl [HyperNode]
nodes
      [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Wire -> [String]) -> [Wire] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Wire -> [String]
wireEdges (HyperGraph -> [Wire]
hgWires HyperGraph
hg)
  where
    nodes :: [HyperNode]
nodes = [HyperNode] -> [HyperNode]
forall a. Eq a => [a] -> [a]
nub (HyperGraph -> [HyperNode]
hgNodes HyperGraph
hg)
    nodeIdOf :: String -> String
nodeIdOf String
lbl = String
"n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show (String -> Int
idxOf String
lbl)
    idxOf :: String -> Int
idxOf String
lbl = case [Int
i | (Int
i, HyperNode
n) <- [Int] -> [HyperNode] -> [(Int, HyperNode)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Int
0 :: Int) ..] [HyperNode]
nodes, HyperNode -> String
hnLabel HyperNode
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lbl] of
      (Int
i : [Int]
_) -> Int
i
      [] -> String -> Int
forall a. HasCallStack => String -> a
error String
"render: port references unknown node"
    arityOf :: String -> HyperNode
arityOf String
lbl = case [HyperNode
n | HyperNode
n <- [HyperNode]
nodes, HyperNode -> String
hnLabel HyperNode
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
lbl] of
      (HyperNode
n : [HyperNode]
_) -> HyperNode
n
      [] -> String -> HyperNode
forall a. HasCallStack => String -> a
error String
"render: port references unknown node"

    inDecl :: a -> String
inDecl a
i = String
"  in" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"([\"in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"])"
    outDecl :: a -> String
outDecl a
i = String
"  out" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"([\"out " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall {a}. Show a => a -> String
show a
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"])"
    nodeDecl :: HyperNode -> String
nodeDecl HyperNode
n = String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
nodeIdOf (HyperNode -> String
hnLabel HyperNode
n) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
shape (HyperNode -> String
hnLabel HyperNode
n)

    shape :: String -> String
shape String
lbl = case String
lbl of
      String
"cup" -> String
"[\"∪\"]"
      String
"cap" -> String
"[\"∩\"]"
      String
"unitL" -> String
"[\"λ\"]"
      String
"unitL'" -> String
"[\"λ⁻¹\"]"
      String
"unitR" -> String
"[\"ρ\"]"
      String
"unitR'" -> String
"[\"ρ⁻¹\"]"
      String
"assoc" -> String
"[\"α\"]"
      String
"assoc'" -> String
"[\"α⁻¹\"]"
      String
"prism" -> String
"{{prism}}"
      String
_ -> String
"[\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
escape String
lbl String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]"

    escape :: String -> String
escape = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' then Char
'\'' else Char
c)

    -- producers point right: boundary inputs and node output ports
    producers :: Wire -> [Either Int PortEnd]
producers Wire
w =
      [Int -> Either Int PortEnd
forall a b. a -> Either a b
Left Int
i | InB Int
i <- Wire -> [BoundaryEnd]
wBoundary Wire
w]
        [Either Int PortEnd]
-> [Either Int PortEnd] -> [Either Int PortEnd]
forall a. [a] -> [a] -> [a]
++ [PortEnd -> Either Int PortEnd
forall a b. b -> Either a b
Right PortEnd
p | p :: PortEnd
p@(PortEnd String
_ PortDir
Out Int
_) <- Wire -> [PortEnd]
wPorts Wire
w]
    -- consumers point left: boundary outputs and node input ports
    consumers :: Wire -> [Either Int PortEnd]
consumers Wire
w =
      [Int -> Either Int PortEnd
forall a b. a -> Either a b
Left Int
i | OutB Int
i <- Wire -> [BoundaryEnd]
wBoundary Wire
w]
        [Either Int PortEnd]
-> [Either Int PortEnd] -> [Either Int PortEnd]
forall a. [a] -> [a] -> [a]
++ [PortEnd -> Either Int PortEnd
forall a b. b -> Either a b
Right PortEnd
p | p :: PortEnd
p@(PortEnd String
_ PortDir
In Int
_) <- Wire -> [PortEnd]
wPorts Wire
w]

    endName :: Either Int PortEnd -> String
endName (Left Int
i) = String
"in" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
i
    endName (Right (PortEnd String
lbl PortDir
_ Int
_)) = String -> String
nodeIdOf String
lbl

    outEndName :: Either Int PortEnd -> String
outEndName (Left Int
i) = String
"out" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
i
    outEndName (Right (PortEnd String
lbl PortDir
_ Int
_)) = String -> String
nodeIdOf String
lbl

    portLabel :: Either Int PortEnd -> Either Int PortEnd -> Maybe String
portLabel Either Int PortEnd
p Either Int PortEnd
c =
      case (Either Int PortEnd
p, Either Int PortEnd
c) of
        (Right (PortEnd String
sl PortDir
_ Int
si), Right (PortEnd String
tl PortDir
_ Int
ti))
          | HyperNode -> Int
hnOutArity (String -> HyperNode
arityOf String
sl) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| HyperNode -> Int
hnInArity (String -> HyperNode
arityOf String
tl) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
              String -> Maybe String
forall a. a -> Maybe a
Just (String
"o" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
si String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
ti)
        (Right (PortEnd String
sl PortDir
_ Int
si), Left Int
_)
          | HyperNode -> Int
hnOutArity (String -> HyperNode
arityOf String
sl) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
              String -> Maybe String
forall a. a -> Maybe a
Just (String
"o" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
si)
        (Left Int
_, Right (PortEnd String
tl PortDir
_ Int
ti))
          | HyperNode -> Int
hnInArity (String -> HyperNode
arityOf String
tl) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
              String -> Maybe String
forall a. a -> Maybe a
Just (String
"i" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall {a}. Show a => a -> String
show Int
ti)
        (Either Int PortEnd, Either Int PortEnd)
_ -> Maybe String
forall a. Maybe a
Nothing

    wireEdges :: Wire -> [String]
wireEdges Wire
w =
      [ String
"  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either Int PortEnd -> String
endName Either Int PortEnd
p String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
edgeLabel (Either Int PortEnd -> Either Int PortEnd -> Maybe String
portLabel Either Int PortEnd
p Either Int PortEnd
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ Either Int PortEnd -> String
outEndName Either Int PortEnd
c
      | Either Int PortEnd
p <- Wire -> [Either Int PortEnd]
producers Wire
w,
        Either Int PortEnd
c <- Wire -> [Either Int PortEnd]
consumers Wire
w
      ]

    edgeLabel :: Maybe String -> String
edgeLabel Maybe String
Nothing = String
" --> "
    edgeLabel (Just String
t) = String
" -->|" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"| "