-- | Hypergraph normal form for the drawing-level hyper fragment of
-- 'SDiagram' ('SWire', 'SSpider', multi-port 'SBox', 'SBeside', 'SThenD',
-- 'SSwap').
--
-- A diagram is interpreted as port connectivity: every node port and
-- every boundary port is a port reference, and a union-find over those
-- references quotients them into wire classes.  Spiders contribute no
-- node — they simply merge the classes of all their ports, so spider
-- fusion (and hence the bialgebra and spider laws) is automatic, and
-- diagrams that differ only in tree shape normalise to the same value.
-- Constructors outside the hyper fragment (cups, caps, unitors, …) are
-- treated as opaque nodes with their natural port arities.
--
-- This is not a full graph-isomorphism check: node ports are keyed by
-- box label, so two boxes carrying the same label are interchangeable.
-- That is exact for the oracle suite and cheap; revisit if unlabelled
-- node isomorphism ever matters.
module Circuit.Diagram.Hyper
  ( HyperGraph (..),
    HyperNode (..),
    Wire (..),
    BoundaryEnd (..),
    PortEnd (..),
    PortDir (..),
    normalise,
    hyperEquiv,
    arity,
  )
where

import Circuit.Diagram (SDiagram (..))
import Data.List (foldl', groupBy, sort, sortOn)
import Prelude

-- $setup
-- >>> import Circuit.Diagram (SDiagram (..))
-- >>> import Circuit.Mermaid (toMermaid)

-- | A diagram as port connectivity: boundary arities, a sorted multiset
-- of nodes, and the wires (equivalence classes of ports).
data HyperGraph = HyperGraph
  { -- | Number of input (left boundary) ports.
    HyperGraph -> Int
hgInArity :: Int,
    -- | Number of output (right boundary) ports.
    HyperGraph -> Int
hgOutArity :: Int,
    -- | Sorted nodes.
    HyperGraph -> [HyperNode]
hgNodes :: [HyperNode],
    -- | Sorted wires.
    HyperGraph -> [Wire]
hgWires :: [Wire]
  }
  deriving (HyperGraph -> HyperGraph -> Bool
(HyperGraph -> HyperGraph -> Bool)
-> (HyperGraph -> HyperGraph -> Bool) -> Eq HyperGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HyperGraph -> HyperGraph -> Bool
== :: HyperGraph -> HyperGraph -> Bool
$c/= :: HyperGraph -> HyperGraph -> Bool
/= :: HyperGraph -> HyperGraph -> Bool
Eq, Int -> HyperGraph -> ShowS
[HyperGraph] -> ShowS
HyperGraph -> String
(Int -> HyperGraph -> ShowS)
-> (HyperGraph -> String)
-> ([HyperGraph] -> ShowS)
-> Show HyperGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HyperGraph -> ShowS
showsPrec :: Int -> HyperGraph -> ShowS
$cshow :: HyperGraph -> String
show :: HyperGraph -> String
$cshowList :: [HyperGraph] -> ShowS
showList :: [HyperGraph] -> ShowS
Show)

-- | A box (or opaque constructor) with its port arities.
data HyperNode = HyperNode
  { HyperNode -> String
hnLabel :: String,
    HyperNode -> Int
hnInArity :: Int,
    HyperNode -> Int
hnOutArity :: Int
  }
  deriving (HyperNode -> HyperNode -> Bool
(HyperNode -> HyperNode -> Bool)
-> (HyperNode -> HyperNode -> Bool) -> Eq HyperNode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HyperNode -> HyperNode -> Bool
== :: HyperNode -> HyperNode -> Bool
$c/= :: HyperNode -> HyperNode -> Bool
/= :: HyperNode -> HyperNode -> Bool
Eq, Eq HyperNode
Eq HyperNode =>
(HyperNode -> HyperNode -> Ordering)
-> (HyperNode -> HyperNode -> Bool)
-> (HyperNode -> HyperNode -> Bool)
-> (HyperNode -> HyperNode -> Bool)
-> (HyperNode -> HyperNode -> Bool)
-> (HyperNode -> HyperNode -> HyperNode)
-> (HyperNode -> HyperNode -> HyperNode)
-> Ord HyperNode
HyperNode -> HyperNode -> Bool
HyperNode -> HyperNode -> Ordering
HyperNode -> HyperNode -> HyperNode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: HyperNode -> HyperNode -> Ordering
compare :: HyperNode -> HyperNode -> Ordering
$c< :: HyperNode -> HyperNode -> Bool
< :: HyperNode -> HyperNode -> Bool
$c<= :: HyperNode -> HyperNode -> Bool
<= :: HyperNode -> HyperNode -> Bool
$c> :: HyperNode -> HyperNode -> Bool
> :: HyperNode -> HyperNode -> Bool
$c>= :: HyperNode -> HyperNode -> Bool
>= :: HyperNode -> HyperNode -> Bool
$cmax :: HyperNode -> HyperNode -> HyperNode
max :: HyperNode -> HyperNode -> HyperNode
$cmin :: HyperNode -> HyperNode -> HyperNode
min :: HyperNode -> HyperNode -> HyperNode
Ord, Int -> HyperNode -> ShowS
[HyperNode] -> ShowS
HyperNode -> String
(Int -> HyperNode -> ShowS)
-> (HyperNode -> String)
-> ([HyperNode] -> ShowS)
-> Show HyperNode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HyperNode -> ShowS
showsPrec :: Int -> HyperNode -> ShowS
$cshow :: HyperNode -> String
show :: HyperNode -> String
$cshowList :: [HyperNode] -> ShowS
showList :: [HyperNode] -> ShowS
Show)

-- | One wire class: the boundary ends and node ports it connects, each
-- sorted.
data Wire = Wire
  { Wire -> [BoundaryEnd]
wBoundary :: [BoundaryEnd],
    Wire -> [PortEnd]
wPorts :: [PortEnd]
  }
  deriving (Wire -> Wire -> Bool
(Wire -> Wire -> Bool) -> (Wire -> Wire -> Bool) -> Eq Wire
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Wire -> Wire -> Bool
== :: Wire -> Wire -> Bool
$c/= :: Wire -> Wire -> Bool
/= :: Wire -> Wire -> Bool
Eq, Eq Wire
Eq Wire =>
(Wire -> Wire -> Ordering)
-> (Wire -> Wire -> Bool)
-> (Wire -> Wire -> Bool)
-> (Wire -> Wire -> Bool)
-> (Wire -> Wire -> Bool)
-> (Wire -> Wire -> Wire)
-> (Wire -> Wire -> Wire)
-> Ord Wire
Wire -> Wire -> Bool
Wire -> Wire -> Ordering
Wire -> Wire -> Wire
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Wire -> Wire -> Ordering
compare :: Wire -> Wire -> Ordering
$c< :: Wire -> Wire -> Bool
< :: Wire -> Wire -> Bool
$c<= :: Wire -> Wire -> Bool
<= :: Wire -> Wire -> Bool
$c> :: Wire -> Wire -> Bool
> :: Wire -> Wire -> Bool
$c>= :: Wire -> Wire -> Bool
>= :: Wire -> Wire -> Bool
$cmax :: Wire -> Wire -> Wire
max :: Wire -> Wire -> Wire
$cmin :: Wire -> Wire -> Wire
min :: Wire -> Wire -> Wire
Ord, Int -> Wire -> ShowS
[Wire] -> ShowS
Wire -> String
(Int -> Wire -> ShowS)
-> (Wire -> String) -> ([Wire] -> ShowS) -> Show Wire
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Wire -> ShowS
showsPrec :: Int -> Wire -> ShowS
$cshow :: Wire -> String
show :: Wire -> String
$cshowList :: [Wire] -> ShowS
showList :: [Wire] -> ShowS
Show)

-- | A diagram boundary port.
data BoundaryEnd
  = -- | Input port (left boundary) at the given index.
    InB Int
  | -- | Output port (right boundary) at the given index.
    OutB Int
  deriving (BoundaryEnd -> BoundaryEnd -> Bool
(BoundaryEnd -> BoundaryEnd -> Bool)
-> (BoundaryEnd -> BoundaryEnd -> Bool) -> Eq BoundaryEnd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BoundaryEnd -> BoundaryEnd -> Bool
== :: BoundaryEnd -> BoundaryEnd -> Bool
$c/= :: BoundaryEnd -> BoundaryEnd -> Bool
/= :: BoundaryEnd -> BoundaryEnd -> Bool
Eq, Eq BoundaryEnd
Eq BoundaryEnd =>
(BoundaryEnd -> BoundaryEnd -> Ordering)
-> (BoundaryEnd -> BoundaryEnd -> Bool)
-> (BoundaryEnd -> BoundaryEnd -> Bool)
-> (BoundaryEnd -> BoundaryEnd -> Bool)
-> (BoundaryEnd -> BoundaryEnd -> Bool)
-> (BoundaryEnd -> BoundaryEnd -> BoundaryEnd)
-> (BoundaryEnd -> BoundaryEnd -> BoundaryEnd)
-> Ord BoundaryEnd
BoundaryEnd -> BoundaryEnd -> Bool
BoundaryEnd -> BoundaryEnd -> Ordering
BoundaryEnd -> BoundaryEnd -> BoundaryEnd
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: BoundaryEnd -> BoundaryEnd -> Ordering
compare :: BoundaryEnd -> BoundaryEnd -> Ordering
$c< :: BoundaryEnd -> BoundaryEnd -> Bool
< :: BoundaryEnd -> BoundaryEnd -> Bool
$c<= :: BoundaryEnd -> BoundaryEnd -> Bool
<= :: BoundaryEnd -> BoundaryEnd -> Bool
$c> :: BoundaryEnd -> BoundaryEnd -> Bool
> :: BoundaryEnd -> BoundaryEnd -> Bool
$c>= :: BoundaryEnd -> BoundaryEnd -> Bool
>= :: BoundaryEnd -> BoundaryEnd -> Bool
$cmax :: BoundaryEnd -> BoundaryEnd -> BoundaryEnd
max :: BoundaryEnd -> BoundaryEnd -> BoundaryEnd
$cmin :: BoundaryEnd -> BoundaryEnd -> BoundaryEnd
min :: BoundaryEnd -> BoundaryEnd -> BoundaryEnd
Ord, Int -> BoundaryEnd -> ShowS
[BoundaryEnd] -> ShowS
BoundaryEnd -> String
(Int -> BoundaryEnd -> ShowS)
-> (BoundaryEnd -> String)
-> ([BoundaryEnd] -> ShowS)
-> Show BoundaryEnd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BoundaryEnd -> ShowS
showsPrec :: Int -> BoundaryEnd -> ShowS
$cshow :: BoundaryEnd -> String
show :: BoundaryEnd -> String
$cshowList :: [BoundaryEnd] -> ShowS
showList :: [BoundaryEnd] -> ShowS
Show)

-- | A node port: box label, direction and port index.
data PortEnd = PortEnd String PortDir Int
  deriving (PortEnd -> PortEnd -> Bool
(PortEnd -> PortEnd -> Bool)
-> (PortEnd -> PortEnd -> Bool) -> Eq PortEnd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortEnd -> PortEnd -> Bool
== :: PortEnd -> PortEnd -> Bool
$c/= :: PortEnd -> PortEnd -> Bool
/= :: PortEnd -> PortEnd -> Bool
Eq, Eq PortEnd
Eq PortEnd =>
(PortEnd -> PortEnd -> Ordering)
-> (PortEnd -> PortEnd -> Bool)
-> (PortEnd -> PortEnd -> Bool)
-> (PortEnd -> PortEnd -> Bool)
-> (PortEnd -> PortEnd -> Bool)
-> (PortEnd -> PortEnd -> PortEnd)
-> (PortEnd -> PortEnd -> PortEnd)
-> Ord PortEnd
PortEnd -> PortEnd -> Bool
PortEnd -> PortEnd -> Ordering
PortEnd -> PortEnd -> PortEnd
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PortEnd -> PortEnd -> Ordering
compare :: PortEnd -> PortEnd -> Ordering
$c< :: PortEnd -> PortEnd -> Bool
< :: PortEnd -> PortEnd -> Bool
$c<= :: PortEnd -> PortEnd -> Bool
<= :: PortEnd -> PortEnd -> Bool
$c> :: PortEnd -> PortEnd -> Bool
> :: PortEnd -> PortEnd -> Bool
$c>= :: PortEnd -> PortEnd -> Bool
>= :: PortEnd -> PortEnd -> Bool
$cmax :: PortEnd -> PortEnd -> PortEnd
max :: PortEnd -> PortEnd -> PortEnd
$cmin :: PortEnd -> PortEnd -> PortEnd
min :: PortEnd -> PortEnd -> PortEnd
Ord, Int -> PortEnd -> ShowS
[PortEnd] -> ShowS
PortEnd -> String
(Int -> PortEnd -> ShowS)
-> (PortEnd -> String) -> ([PortEnd] -> ShowS) -> Show PortEnd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortEnd -> ShowS
showsPrec :: Int -> PortEnd -> ShowS
$cshow :: PortEnd -> String
show :: PortEnd -> String
$cshowList :: [PortEnd] -> ShowS
showList :: [PortEnd] -> ShowS
Show)

-- | Whether a node port is an input or an output.
data PortDir = In | Out
  deriving (PortDir -> PortDir -> Bool
(PortDir -> PortDir -> Bool)
-> (PortDir -> PortDir -> Bool) -> Eq PortDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortDir -> PortDir -> Bool
== :: PortDir -> PortDir -> Bool
$c/= :: PortDir -> PortDir -> Bool
/= :: PortDir -> PortDir -> Bool
Eq, Eq PortDir
Eq PortDir =>
(PortDir -> PortDir -> Ordering)
-> (PortDir -> PortDir -> Bool)
-> (PortDir -> PortDir -> Bool)
-> (PortDir -> PortDir -> Bool)
-> (PortDir -> PortDir -> Bool)
-> (PortDir -> PortDir -> PortDir)
-> (PortDir -> PortDir -> PortDir)
-> Ord PortDir
PortDir -> PortDir -> Bool
PortDir -> PortDir -> Ordering
PortDir -> PortDir -> PortDir
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PortDir -> PortDir -> Ordering
compare :: PortDir -> PortDir -> Ordering
$c< :: PortDir -> PortDir -> Bool
< :: PortDir -> PortDir -> Bool
$c<= :: PortDir -> PortDir -> Bool
<= :: PortDir -> PortDir -> Bool
$c> :: PortDir -> PortDir -> Bool
> :: PortDir -> PortDir -> Bool
$c>= :: PortDir -> PortDir -> Bool
>= :: PortDir -> PortDir -> Bool
$cmax :: PortDir -> PortDir -> PortDir
max :: PortDir -> PortDir -> PortDir
$cmin :: PortDir -> PortDir -> PortDir
min :: PortDir -> PortDir -> PortDir
Ord, Int -> PortDir -> ShowS
[PortDir] -> ShowS
PortDir -> String
(Int -> PortDir -> ShowS)
-> (PortDir -> String) -> ([PortDir] -> ShowS) -> Show PortDir
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortDir -> ShowS
showsPrec :: Int -> PortDir -> ShowS
$cshow :: PortDir -> String
show :: PortDir -> String
$cshowList :: [PortDir] -> ShowS
showList :: [PortDir] -> ShowS
Show)

-- | Boundary port counts of a diagram: @(inputs, outputs)@.  The unit of
-- a unitor carries no wire, so unitors are @1 -> 1@.
arity :: SDiagram -> (Int, Int)
arity :: SDiagram -> (Int, Int)
arity = \case
  SDiagram
SWire -> (Int
1, Int
1)
  SBox String
_ Int
m Int
n -> (Int
m, Int
n)
  SSpider Int
m Int
n -> (Int
m, Int
n)
  SDiagram
SPrismBox -> (Int
1, Int
1)
  SBeside SDiagram
f SDiagram
g ->
    let (Int
fi, Int
fo) = SDiagram -> (Int, Int)
arity SDiagram
f
        (Int
gi, Int
go') = SDiagram -> (Int, Int)
arity SDiagram
g
     in (Int
fi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
gi, Int
fo Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
go')
  SThenD SDiagram
f SDiagram
g -> ((Int, Int) -> Int
forall a b. (a, b) -> a
fst (SDiagram -> (Int, Int)
arity SDiagram
f), (Int, Int) -> Int
forall a b. (a, b) -> b
snd (SDiagram -> (Int, Int)
arity SDiagram
g))
  SDiagram
SBend -> (Int
2, Int
0)
  SDiagram
SBend' -> (Int
0, Int
2)
  STurn SDiagram
d -> let (Int
i, Int
o) = SDiagram -> (Int, Int)
arity SDiagram
d in (Int
o, Int
i)
  SDiagram
SUnitL -> (Int
1, Int
1)
  SDiagram
SUnitL' -> (Int
1, Int
1)
  SDiagram
SUnitR -> (Int
1, Int
1)
  SDiagram
SUnitR' -> (Int
1, Int
1)
  SDiagram
SAssoc -> (Int
3, Int
3)
  SDiagram
SAssoc' -> (Int
3, Int
3)
  SDiagram
SSwap -> (Int
2, Int
2)
  STrace SDiagram
d ->
    let (Int
i, Int
o) = SDiagram -> (Int, Int)
arity SDiagram
d
     in (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1, Int
o Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

-- | Interpret a diagram as its hypergraph normal form.
--
-- Assumes composable diagrams ('SThenD' zips the inner ports and drops
-- any excess): the drawing syntax is untyped, so ill-formed composites
-- degrade to dangling ports rather than an error.
--
-- 'STurn' is involutive and reverses composition order:
--
-- >>> hyperEquiv (STurn (STurn (SBox "f" 1 1))) (SBox "f" 1 1)
-- True
-- >>> hyperEquiv (STurn (SThenD (SBox "f" 1 1) (SBox "g" 1 1))) (SThenD (STurn (SBox "g" 1 1)) (STurn (SBox "f" 1 1)))
-- True
--
-- >>> putStr (toMermaid (STurn (SBox "f" 1 1)))
-- flowchart LR
--   in0(["in 0"])
--   out0(["out 0"])
--   n0["f†"]
--   in0 --> n0
--   n0 --> out0
normalise :: SDiagram -> HyperGraph
normalise :: SDiagram -> HyperGraph
normalise SDiagram
d =
  HyperGraph
    { hgInArity :: Int
hgInArity = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
ins,
      hgOutArity :: Int
hgOutArity = [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
outs,
      hgNodes :: [HyperNode]
hgNodes =
        [HyperNode] -> [HyperNode]
forall a. Ord a => [a] -> [a]
sort
          [ String -> Int -> Int -> HyperNode
HyperNode String
lbl ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
bins) ([Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
bouts)
          | BuiltNode String
lbl [Int]
bins [Int]
bouts <- Build -> [BuiltNode]
builtNodes Build
b
          ],
      hgWires :: [Wire]
hgWires = [Wire] -> [Wire]
forall a. Ord a => [a] -> [a]
sort ([(Int, End)] -> Wire
forall {a}. [(a, End)] -> Wire
mkWire ([(Int, End)] -> Wire) -> [[(Int, End)]] -> [Wire]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Int, End)]]
classes)
    }
  where
    (Build
b, ([Int]
ins, [Int]
outs)) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
d Build
emptyBuild
    rootOf :: Int -> Int
rootOf = [(Int, Int)] -> Int -> Int
findRoot (Build -> [(Int, Int)]
parent Build
b)
    classes :: [[(Int, End)]]
classes =
      ((Int, End) -> (Int, End) -> Bool)
-> [(Int, End)] -> [[(Int, End)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy
        (\(Int, End)
e (Int, End)
e' -> Int -> Int
rootOf ((Int, End) -> Int
forall a b. (a, b) -> a
fst (Int, End)
e) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> Int
rootOf ((Int, End) -> Int
forall a b. (a, b) -> a
fst (Int, End)
e'))
        (((Int, End) -> Int) -> [(Int, End)] -> [(Int, End)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Int
rootOf (Int -> Int) -> ((Int, End) -> Int) -> (Int, End) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, End) -> Int
forall a b. (a, b) -> a
fst) [(Int, End)]
allEnds)
    allEnds :: [(Int, End)]
allEnds =
      [(Int
p, BoundaryEnd -> End
BoundaryE (Int -> BoundaryEnd
InB Int
ix)) | (Int
ix, Int
p) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
ins]
        [(Int, End)] -> [(Int, End)] -> [(Int, End)]
forall a. [a] -> [a] -> [a]
++ [(Int
p, BoundaryEnd -> End
BoundaryE (Int -> BoundaryEnd
OutB Int
ix)) | (Int
ix, Int
p) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
outs]
        [(Int, End)] -> [(Int, End)] -> [(Int, End)]
forall a. [a] -> [a] -> [a]
++ [ (Int
p, PortEnd -> End
PortE (String -> PortDir -> Int -> PortEnd
PortEnd String
lbl PortDir
dir Int
ix))
           | BuiltNode String
lbl [Int]
bins [Int]
bouts <- Build -> [BuiltNode]
builtNodes Build
b,
             (PortDir
dir, [Int]
ports) <- [(PortDir
In, [Int]
bins), (PortDir
Out, [Int]
bouts)],
             (Int
ix, Int
p) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
ports
           ]
    mkWire :: [(a, End)] -> Wire
mkWire [(a, End)]
es =
      [BoundaryEnd] -> [PortEnd] -> Wire
Wire
        ([BoundaryEnd] -> [BoundaryEnd]
forall a. Ord a => [a] -> [a]
sort [BoundaryEnd
e | (a
_, BoundaryE BoundaryEnd
e) <- [(a, End)]
es])
        ([PortEnd] -> [PortEnd]
forall a. Ord a => [a] -> [a]
sort [PortEnd
e | (a
_, PortE PortEnd
e) <- [(a, End)]
es])

-- | Structural equality of diagrams up to hypergraph connectivity.
hyperEquiv :: SDiagram -> SDiagram -> Bool
hyperEquiv :: SDiagram -> SDiagram -> Bool
hyperEquiv SDiagram
f SDiagram
g = SDiagram -> HyperGraph
normalise SDiagram
f HyperGraph -> HyperGraph -> Bool
forall a. Eq a => a -> a -> Bool
== SDiagram -> HyperGraph
normalise SDiagram
g

--------------------------------------------------------------------------------
-- build: union-find over port references
--------------------------------------------------------------------------------

-- | A node under construction, with its port references.
data BuiltNode = BuiltNode String [Int] [Int]

data Build = Build
  { Build -> Int
nextPort :: Int,
    Build -> [(Int, Int)]
parent :: [(Int, Int)],
    Build -> [BuiltNode]
builtNodes :: [BuiltNode]
  }

emptyBuild :: Build
emptyBuild :: Build
emptyBuild = Int -> [(Int, Int)] -> [BuiltNode] -> Build
Build Int
0 [] []

fresh :: Build -> (Build, Int)
fresh :: Build -> (Build, Int)
fresh Build
b = (Build
b {nextPort = nextPort b + 1}, Build -> Int
nextPort Build
b)

freshPorts :: Int -> Build -> (Build, [Int])
freshPorts :: Int -> Build -> (Build, [Int])
freshPorts Int
n Build
b0 = ((Build, [Int]) -> Int -> (Build, [Int]))
-> (Build, [Int]) -> [Int] -> (Build, [Int])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Build, [Int]) -> Int -> (Build, [Int])
forall {p}. (Build, [Int]) -> p -> (Build, [Int])
step (Build
b0, []) [Int
1 .. Int
n]
  where
    step :: (Build, [Int]) -> p -> (Build, [Int])
step (Build
b, [Int]
ps) p
_ = let (Build
b', Int
p) = Build -> (Build, Int)
fresh Build
b in (Build
b', [Int]
ps [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
p])

findRoot :: [(Int, Int)] -> Int -> Int
findRoot :: [(Int, Int)] -> Int -> Int
findRoot [(Int, Int)]
ps Int
p = case Int -> [(Int, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
p [(Int, Int)]
ps of
  Maybe Int
Nothing -> Int
p
  Just Int
q -> [(Int, Int)] -> Int -> Int
findRoot [(Int, Int)]
ps Int
q

-- | Toggle a dagger suffix. Used by 'STurn' so that turning a turned node
-- recovers the original label.
turnLabel :: String -> String
turnLabel :: ShowS
turnLabel String
lbl = case ShowS
forall a. [a] -> [a]
reverse String
lbl of
  (Char
'\x2020' : String
rest) -> ShowS
forall a. [a] -> [a]
reverse String
rest
  String
_ -> String
lbl String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\x2020"

-- | Merge the classes of two ports (first root wins, for determinism).
-- Ports already in the same class are left alone — recording the link
-- would create a self-loop.
unite :: Int -> Int -> Build -> Build
unite :: Int -> Int -> Build -> Build
unite Int
p Int
q Build
b =
  let rp :: Int
rp = [(Int, Int)] -> Int -> Int
findRoot (Build -> [(Int, Int)]
parent Build
b) Int
p
      rq :: Int
rq = [(Int, Int)] -> Int -> Int
findRoot (Build -> [(Int, Int)]
parent Build
b) Int
q
   in if Int
rp Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
rq then Build
b else Build
b {parent = (rq, rp) : parent b}

addNode :: String -> [Int] -> [Int] -> Build -> Build
addNode :: String -> [Int] -> [Int] -> Build -> Build
addNode String
lbl [Int]
ins [Int]
outs Build
b = Build
b {builtNodes = BuiltNode lbl ins outs : builtNodes b}

-- | An opaque node with the given port arities.
node :: String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node :: String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
lbl Int
m Int
n Build
b0 =
  let (Build
b1, [Int]
ins) = Int -> Build -> (Build, [Int])
freshPorts Int
m Build
b0
      (Build
b2, [Int]
outs) = Int -> Build -> (Build, [Int])
freshPorts Int
n Build
b1
   in (String -> [Int] -> [Int] -> Build -> Build
addNode String
lbl [Int]
ins [Int]
outs Build
b2, ([Int]
ins, [Int]
outs))

-- | Traverse the tree, returning the boundary port references.
go :: SDiagram -> Build -> (Build, ([Int], [Int]))
go :: SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
d Build
b0 = case SDiagram
d of
  SDiagram
SWire ->
    let (Build
b1, Int
p) = Build -> (Build, Int)
fresh Build
b0
        (Build
b2, Int
q) = Build -> (Build, Int)
fresh Build
b1
     in (Int -> Int -> Build -> Build
unite Int
p Int
q Build
b2, ([Int
p], [Int
q]))
  SBox String
lbl Int
m Int
n -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
lbl Int
m Int
n Build
b0
  SSpider Int
m Int
n ->
    let (Build
b1, [Int]
ins) = Int -> Build -> (Build, [Int])
freshPorts Int
m Build
b0
        (Build
b2, [Int]
outs) = Int -> Build -> (Build, [Int])
freshPorts Int
n Build
b1
        b3 :: Build
b3 = case [Int]
ins [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
outs of
          [] -> Build
b2
          (Int
p : [Int]
ps) -> (Build -> Int -> Build) -> Build -> [Int] -> Build
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ((Int -> Build -> Build) -> Build -> Int -> Build
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Int -> Int -> Build -> Build
unite Int
p)) Build
b2 [Int]
ps
     in (Build
b3, ([Int]
ins, [Int]
outs))
  SDiagram
SPrismBox -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"prism" Int
1 Int
1 Build
b0
  SBeside SDiagram
f SDiagram
g ->
    let (Build
b1, ([Int]
fi, [Int]
fo)) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
f Build
b0
        (Build
b2, ([Int]
gi, [Int]
go')) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
g Build
b1
     in (Build
b2, ([Int]
fi [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
gi, [Int]
fo [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
go'))
  SThenD SDiagram
f SDiagram
g ->
    let (Build
b1, ([Int]
fi, [Int]
fo)) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
f Build
b0
        (Build
b2, ([Int]
gi, [Int]
go')) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
g Build
b1
        b3 :: Build
b3 = (Build -> (Int, Int) -> Build) -> Build -> [(Int, Int)] -> Build
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Build
bb (Int
p, Int
q) -> Int -> Int -> Build -> Build
unite Int
p Int
q Build
bb) Build
b2 ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
fo [Int]
gi)
     in (Build
b3, ([Int]
fi, [Int]
go'))
  SDiagram
SBend -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"cup" Int
2 Int
0 Build
b0
  SDiagram
SBend' -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"cap" Int
0 Int
2 Build
b0
  STurn SDiagram
d' ->
    let oldCount :: Int
oldCount = [BuiltNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Build -> [BuiltNode]
builtNodes Build
b0)
        (Build
b1, ([Int]
ins, [Int]
outs)) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
d' Build
b0
        newCount :: Int
newCount = [BuiltNode] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Build -> [BuiltNode]
builtNodes Build
b1) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
oldCount
        ([BuiltNode]
newNodes, [BuiltNode]
oldNodes) = Int -> [BuiltNode] -> ([BuiltNode], [BuiltNode])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
newCount (Build -> [BuiltNode]
builtNodes Build
b1)
        turnedNewNodes :: [BuiltNode]
turnedNewNodes =
          [ String -> [Int] -> [Int] -> BuiltNode
BuiltNode (ShowS
turnLabel String
lbl) ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
outs') ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ins')
          | BuiltNode String
lbl [Int]
ins' [Int]
outs' <- [BuiltNode]
newNodes
          ]
     in (Build
b1 {builtNodes = turnedNewNodes ++ oldNodes}, ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
outs, [Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
ins))
  SDiagram
SUnitL -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"unitL" Int
1 Int
1 Build
b0
  SDiagram
SUnitL' -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"unitL'" Int
1 Int
1 Build
b0
  SDiagram
SUnitR -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"unitR" Int
1 Int
1 Build
b0
  SDiagram
SUnitR' -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"unitR'" Int
1 Int
1 Build
b0
  SDiagram
SAssoc -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"assoc" Int
3 Int
3 Build
b0
  SDiagram
SAssoc' -> String -> Int -> Int -> Build -> (Build, ([Int], [Int]))
node String
"assoc'" Int
3 Int
3 Build
b0
  SDiagram
SSwap ->
    let (Build
b1, Int
i0) = Build -> (Build, Int)
fresh Build
b0
        (Build
b2, Int
i1) = Build -> (Build, Int)
fresh Build
b1
        (Build
b3, Int
o0) = Build -> (Build, Int)
fresh Build
b2
        (Build
b4, Int
o1) = Build -> (Build, Int)
fresh Build
b3
     in (Int -> Int -> Build -> Build
unite Int
i0 Int
o1 (Int -> Int -> Build -> Build
unite Int
i1 Int
o0 Build
b4), ([Int
i0, Int
i1], [Int
o0, Int
o1]))
  STrace SDiagram
d' ->
    let (Build
b1, ([Int]
ins, [Int]
outs)) = SDiagram -> Build -> (Build, ([Int], [Int]))
go SDiagram
d' Build
b0
        initLast :: [a] -> ([a], [a])
initLast [a]
xs = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt ([a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [a]
xs
     in case ([Int] -> ([Int], [Int])
forall {a}. [a] -> ([a], [a])
initLast [Int]
ins, [Int] -> ([Int], [Int])
forall {a}. [a] -> ([a], [a])
initLast [Int]
outs) of
          (([Int]
is, [Int
i]), ([Int]
os, [Int
o])) -> (Int -> Int -> Build -> Build
unite Int
i Int
o Build
b1, ([Int]
is, [Int]
os))
          (([Int], [Int]), ([Int], [Int]))
_ -> (Build
b1, ([Int]
ins, [Int]
outs))

-- | A port end while grouping: either a boundary port or a node port.
data End = BoundaryE BoundaryEnd | PortE PortEnd