{-# LANGUAGE AllowAmbiguousTypes #-}

-- | __Open hypergraphs__ with typed wires: decorated cospans ("Proarrow.Category.Instance.DecoratedCospan")
-- of finite sets whose elements have sorts, decorated with labelled boxes. A morphism has nodes, each
-- of some sort, boxes attached to them, and two boundaries of sorted ports. It is a morphism of the
-- free hypergraph category on its boxes, and two such morphisms are equal by the Frobenius laws
-- exactly when they are 'isomorphic'.
--
-- The sorts are objects of a category @s@, known at runtime, so that a computed apex knows the sorts
-- of its nodes. A list of sorts @xs@ gives the boundary @'Wires' xs@. Comparing two open hypergraphs,
-- or checking sorts given from outside, asks whether two sorts are isomorphic ('DecidableIso').
module Proarrow.Category.Instance.OpenHypergraph
  ( -- * Sorts
    SomeSort
  , SortOb
  , Sorted
  , PortSorts
  , sortOf
  , Sorts
  , SortList
  , sorts
  , sortList
  , Port (..)
  , SORTED
  , reifySorts

    -- * Open hypergraphs
  , OPENHG
  , Wires
  , Box (..)
  , Boxes (..)
  , WireSorts
  , box
  , openHypergraph
  , unsafeOpenHypergraph
  , SomeHypergraph (..)
  , substitute
  , substituteWith
  , unsafeSubstituteWith
  , isomorphic
  , sameSort

    -- * Read-back
  , SomeArrow (..)
  , someArrow
  , readBack
  , Wiring
  , permutations
  , copyDiscard
  , frobenius
  , frobeniusWith
  , tracedWith
  , layered

    -- * Simplifying
  , SIMPLIFY
  , Prim
  , unsafePrim
  , prim
  , prim0
  , prim1
  , prim2
  , prim3
  , simplify
  , simplifyHypergraph
  , simplifyFlat
  ) where

import Control.Monad (foldM, msum)
import Data.Containers.ListUtils (nubOrd)
import Data.Kind (Constraint, Type)
import Data.List qualified as List
import Data.Map.Strict qualified as M
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Ord (comparing)
import Data.Set qualified as Set
import Data.Type.Equality (type (~))
import Data.Universe.Class (Finite (..), Universe (..))
import Unsafe.Coerce (unsafeCoerce)
import Prelude qualified as P

import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..))
import Proarrow.Category.Instance.FinHask (FINHASK (..), FinHask (..), unionFind)
import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))
import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor, type (**))
import Proarrow.Category.Monoidal.Applicative (Alternative (..))
import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)
import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cupS, traceHG)
import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal)
import Proarrow.Category.Monoidal.Strictified
  ( Fold
  , Strictified (..)
  , concatMany
  , obj1
  , singleton
  , splitMany
  , swap2
  , withIsListOf
  , type (++)
  )
import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))
import Proarrow.Colimit.Initial (HasInitialObject (..))
import Proarrow.Colimit.Pushout (HasPushouts (..))
import Proarrow.Core (CategoryOf (..), Hom, Kind, OB, Ob', Profunctor, Promonad (..), UN, obj, (//))
import Proarrow.Functor (Functor (..))
import Proarrow.Monoid (CocommutativeComonoid, Supplies, comultS, counitS, mappendS, memptyS)
import Proarrow.Object
  ( KnownListOf (..)
  , ListOf (..)
  , SomeOf (..)
  , appendListOf
  , lengthListOf
  , someOfList
  , withKnownAppend
  , withKnownListOf
  , withListOf
  , pattern Objs
  )
import Proarrow.Optic.Iso (DecidableIso (..), withIso)
import Proarrow.Tools.ContractionOrder (Plan (..), planContraction)

-- * Sorts

-- | A sort of kind @s@, an object of the category of @s@, known at runtime.
type SomeSort :: Kind -> Type
type SomeSort s = SomeOf (SortOb @s)

-- | The evidence a sort carries: objecthood.
type SortOb :: forall s. s -> Constraint
type SortOb @s = (Ob' :: s -> Constraint)

-- | Whether two sorts are isomorphic.
sameSort :: forall s. (DecidableIso s) => SomeSort s -> SomeSort s -> P.Bool
sameSort :: forall s. DecidableIso s => SomeSort s -> SomeSort s -> Bool
sameSort = Align s -> SomeSort s -> SomeSort s -> Bool
forall s. Align s -> SomeSort s -> SomeSort s -> Bool
lineUp (forall s. DecidableIso s => Align s
byIso @s)

-- | The sorts of the ports of a sorted finite set.
type PortSorts :: forall s. FINHASK -> [s]
type family PortSorts a where
  PortSorts (FH (Port xs)) = xs

-- | The finite sets of ports with sorts of kind @s@, @'FH' (Port xs)@.
type Sorted :: Kind -> OB FINHASK
class (Ob a, a ~ FH (Port (PortSorts @s a)), SortList (PortSorts @s a)) => Sorted s a

instance (Ob a, a ~ FH (Port (PortSorts @s a)), SortList (PortSorts @s a)) => Sorted s a

-- | The sort of a port.
sortOf :: forall s a. (Sorted s a) => UN FH a -> SomeSort s
sortOf :: forall s (a :: FINHASK). Sorted s a => UN FH a -> SomeSort s
sortOf = \(Port Int
i) -> Map Int (SomeSort s)
table Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
  where
    table :: Map Int (SomeSort s)
table = [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] (forall s (xs :: [s]). SortList xs => [SomeSort s]
sortList @s @(PortSorts @s a)))

-- | A list of sorts, each an object known at runtime.
type Sorts :: forall s. [s] -> Type
type Sorts @s = ListOf (SortOb @s)

-- | A list of sorts known at runtime.
type SortList :: forall s. [s] -> Constraint
type SortList xs = KnownListOf SortOb xs

-- | The list of sorts as a value.
sorts :: forall s (xs :: [s]). (SortList xs) => Sorts xs
sorts :: forall s (xs :: [s]). SortList xs => Sorts xs
sorts = ListOf SortOb xs
forall {k} (c :: OB k) (xs :: [k]). KnownListOf c xs => ListOf c xs
listOf

-- | The sorts of the list, one by one.
sortList :: forall s (xs :: [s]). (SortList xs) => [SomeSort s]
sortList :: forall s (xs :: [s]). SortList xs => [SomeSort s]
sortList = ListOf SortOb xs -> [SomeOf SortOb]
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> [SomeOf c]
someOfList (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @xs)

-- | The ports of a list of sorts: one for each position, of the sort at that position.
type Port :: [s] -> Type
newtype Port xs = Port P.Int
  deriving (Port xs -> Port xs -> Bool
(Port xs -> Port xs -> Bool)
-> (Port xs -> Port xs -> Bool) -> Eq (Port xs)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall s (xs :: [s]). Port xs -> Port xs -> Bool
$c== :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
== :: Port xs -> Port xs -> Bool
$c/= :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
/= :: Port xs -> Port xs -> Bool
P.Eq, Eq (Port xs)
Eq (Port xs) =>
(Port xs -> Port xs -> Ordering)
-> (Port xs -> Port xs -> Bool)
-> (Port xs -> Port xs -> Bool)
-> (Port xs -> Port xs -> Bool)
-> (Port xs -> Port xs -> Bool)
-> (Port xs -> Port xs -> Port xs)
-> (Port xs -> Port xs -> Port xs)
-> Ord (Port xs)
Port xs -> Port xs -> Bool
Port xs -> Port xs -> Ordering
Port xs -> Port xs -> Port xs
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
forall s (xs :: [s]). Eq (Port xs)
forall s (xs :: [s]). Port xs -> Port xs -> Bool
forall s (xs :: [s]). Port xs -> Port xs -> Ordering
forall s (xs :: [s]). Port xs -> Port xs -> Port xs
$ccompare :: forall s (xs :: [s]). Port xs -> Port xs -> Ordering
compare :: Port xs -> Port xs -> Ordering
$c< :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
< :: Port xs -> Port xs -> Bool
$c<= :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
<= :: Port xs -> Port xs -> Bool
$c> :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
> :: Port xs -> Port xs -> Bool
$c>= :: forall s (xs :: [s]). Port xs -> Port xs -> Bool
>= :: Port xs -> Port xs -> Bool
$cmax :: forall s (xs :: [s]). Port xs -> Port xs -> Port xs
max :: Port xs -> Port xs -> Port xs
$cmin :: forall s (xs :: [s]). Port xs -> Port xs -> Port xs
min :: Port xs -> Port xs -> Port xs
P.Ord, Int -> Port xs -> ShowS
[Port xs] -> ShowS
Port xs -> String
(Int -> Port xs -> ShowS)
-> (Port xs -> String) -> ([Port xs] -> ShowS) -> Show (Port xs)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall s (xs :: [s]). Int -> Port xs -> ShowS
forall s (xs :: [s]). [Port xs] -> ShowS
forall s (xs :: [s]). Port xs -> String
$cshowsPrec :: forall s (xs :: [s]). Int -> Port xs -> ShowS
showsPrec :: Int -> Port xs -> ShowS
$cshow :: forall s (xs :: [s]). Port xs -> String
show :: Port xs -> String
$cshowList :: forall s (xs :: [s]). [Port xs] -> ShowS
showList :: [Port xs] -> ShowS
P.Show)

instance (SortList (xs :: [s])) => Universe (Port xs) where
  universe :: [Port xs]
universe = (Int -> Port xs) -> [Int] -> [Port xs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Port xs
forall s (xs :: [s]). Int -> Port xs
Port [Int
0 .. ListOf SortOb xs -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @xs) Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1]
instance (SortList (xs :: [s])) => Finite (Port xs)

-- | A list of sorts known at runtime as a type-level list.
reifySorts :: forall s r. [SomeSort s] -> (forall (xs :: [s]). (SortList xs) => r) -> r
reifySorts :: forall s r.
[SomeSort s] -> (forall (xs :: [s]). SortList xs => r) -> r
reifySorts [SomeSort s]
ss forall (xs :: [s]). SortList xs => r
k = [SomeSort s] -> (forall (xs :: [s]). ListOf SortOb xs -> r) -> r
forall {k} (c :: OB k) r.
[SomeOf c] -> (forall (xs :: [k]). ListOf c xs -> r) -> r
withListOf [SomeSort s]
ss \ @xs ListOf SortOb xs
l -> ListOf SortOb xs -> (KnownListOf SortOb xs => r) -> r
forall {k} (c :: OB k) (xs :: [k]) r.
ListOf c xs -> (KnownListOf c xs => r) -> r
withKnownListOf ListOf SortOb xs
l (forall (xs :: [s]). SortList xs => r
k @xs)

-- | The finite sets whose elements have sorts of kind @s@: a full subcategory of 'FINHASK'.
type SORTED :: Kind -> Kind
type SORTED s = SUBCAT (Sorted s)

-- | No ports.
instance HasInitialObject (SORTED s) where
  type InitialObject @(SORTED s) = SUB (FH (Port ('[] :: [s])))
  initiate :: forall (a :: SORTED s). Ob a => InitialObject ~> a
initiate = FinHask
  (FH (Port '[])) (FH (Port (PortSorts (FH (UN FH (UN SUB a))))))
-> Sub
     FinHask
     (SUB (FH (Port '[])))
     (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB a)))))))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (Map (Port '[]) (Port (PortSorts (FH (UN FH (UN SUB a)))))
-> FinHask
     (FH (Port '[])) (FH (Port (PortSorts (FH (UN FH (UN SUB a))))))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask Map (Port '[]) (Port (PortSorts (FH (UN FH (UN SUB a)))))
forall k a. Map k a
M.empty)

-- | The ports of both, those of the second numbered after those of the first.
instance HasBinaryCoproducts (SORTED s) where
  type (||) @(SORTED s) a b = SUB (FH (Port (PortSorts @s (UN SUB a) ++ PortSorts @s (UN SUB b))))
  withObCoprod :: forall (a :: SORTED s) (b :: SORTED s) r.
(Ob a, Ob b) =>
(Ob (a || b) => r) -> r
withObCoprod @a @b Ob (a || b) => r
r = forall {k} (c :: OB k) (as :: [k]) (bs :: [k]) r.
(KnownListOf c as, KnownListOf c bs) =>
(KnownListOf c (as ++ bs) => r) -> r
forall (c :: OB s) (as :: [s]) (bs :: [s]) r.
(KnownListOf c as, KnownListOf c bs) =>
(KnownListOf c (as ++ bs) => r) -> r
withKnownAppend @SortOb @(PortSorts @s (UN SUB a)) @(PortSorts @s (UN SUB b)) r
Ob (a || b) => r
KnownListOf
  SortOb (PortSorts (UN SUB a) ++ PortSorts (UN SUB b)) =>
r
r
  lft :: forall (a :: SORTED s) (b :: SORTED s).
(Ob a, Ob b) =>
a ~> (a || b)
lft @a @b =
    forall k (a :: k) (b :: k) r.
(HasBinaryCoproducts k, Ob a, Ob b) =>
(Ob (a || b) => r) -> r
withObCoprod @(SORTED s) @a @b
      (FinHask
  (FH (Port (PortSorts (FH (UN FH (UN SUB a))))))
  (FH
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b))))))
-> Sub
     FinHask
     (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB a)))))))
     (SUB
        (FH
           (Port
              (PortSorts (FH (UN FH (UN SUB a)))
               ++ PortSorts (FH (UN FH (UN SUB b)))))))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (Map
  (Port (PortSorts (FH (UN FH (UN SUB a)))))
  (Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b)))))
-> FinHask
     (FH (Port (PortSorts (FH (UN FH (UN SUB a))))))
     (FH
        (Port
           (PortSorts (FH (UN FH (UN SUB a)))
            ++ PortSorts (FH (UN FH (UN SUB b))))))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask ([(Port (PortSorts (FH (UN FH (UN SUB a)))),
  Port
    (PortSorts (FH (UN FH (UN SUB a)))
     ++ PortSorts (FH (UN FH (UN SUB b)))))]
-> Map
     (Port (PortSorts (FH (UN FH (UN SUB a)))))
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b)))))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int -> Port (PortSorts (FH (UN FH (UN SUB a))))
forall s (xs :: [s]). Int -> Port xs
Port Int
i, Int
-> Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b))))
forall s (xs :: [s]). Int -> Port xs
Port Int
i) | Port Int
i <- forall a. Finite a => [a]
universeF @(Port (PortSorts @s (UN SUB a)))])))
  rgt :: forall (a :: SORTED s) (b :: SORTED s).
(Ob a, Ob b) =>
b ~> (a || b)
rgt @a @b =
    forall k (a :: k) (b :: k) r.
(HasBinaryCoproducts k, Ob a, Ob b) =>
(Ob (a || b) => r) -> r
withObCoprod @(SORTED s) @a @b
      ( FinHask
  (FH (Port (PortSorts (FH (UN FH (UN SUB b))))))
  (FH
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b))))))
-> Sub
     FinHask
     (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB b)))))))
     (SUB
        (FH
           (Port
              (PortSorts (FH (UN FH (UN SUB a)))
               ++ PortSorts (FH (UN FH (UN SUB b)))))))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub
          ( Map
  (Port (PortSorts (FH (UN FH (UN SUB b)))))
  (Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b)))))
-> FinHask
     (FH (Port (PortSorts (FH (UN FH (UN SUB b))))))
     (FH
        (Port
           (PortSorts (FH (UN FH (UN SUB a)))
            ++ PortSorts (FH (UN FH (UN SUB b))))))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask
              ( [(Port (PortSorts (FH (UN FH (UN SUB b)))),
  Port
    (PortSorts (FH (UN FH (UN SUB a)))
     ++ PortSorts (FH (UN FH (UN SUB b)))))]
-> Map
     (Port (PortSorts (FH (UN FH (UN SUB b)))))
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b)))))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
                  [ (Int -> Port (PortSorts (FH (UN FH (UN SUB b))))
forall s (xs :: [s]). Int -> Port xs
Port Int
j, Int
-> Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b))))
forall s (xs :: [s]). Int -> Port xs
Port (ListOf SortOb (PortSorts (FH (UN FH (UN SUB a)))) -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(PortSorts @s (UN SUB a))) Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
j))
                  | Port Int
j <- forall a. Finite a => [a]
universeF @(Port (PortSorts @s (UN SUB b)))
                  ]
              )
          )
      )
  ||| :: forall (x :: SORTED s) (a :: SORTED s) (y :: SORTED s).
(x ~> a) -> (y ~> a) -> (x || y) ~> a
(|||) @x @_ @y (Sub (FinHask Map a1 b1
f)) (Sub (FinHask Map a1 b1
g)) =
    forall k (a :: k) (b :: k) r.
(HasBinaryCoproducts k, Ob a, Ob b) =>
(Ob (a || b) => r) -> r
withObCoprod @(SORTED s) @x @y ((Ob (x || y) => (x || y) ~> a) -> (x || y) ~> a)
-> (Ob (x || y) => (x || y) ~> a) -> (x || y) ~> a
forall a b. (a -> b) -> a -> b
P.$
      FinHask (FH (Port (PortSorts a1 ++ PortSorts a1))) (FH b1)
-> Sub
     FinHask
     (SUB (FH (Port (PortSorts a1 ++ PortSorts a1))))
     (SUB (FH b1))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub
        ( Map (Port (PortSorts a1 ++ PortSorts a1)) b1
-> FinHask (FH (Port (PortSorts a1 ++ PortSorts a1))) (FH b1)
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask
            ([(Port (PortSorts a1 ++ PortSorts a1), b1)]
-> Map (Port (PortSorts a1 ++ PortSorts a1)) b1
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Int -> Port (PortSorts a1 ++ PortSorts a1)
forall s (xs :: [s]). Int -> Port xs
Port Int
i, b1
x) | (Port Int
i, b1
x) <- Map a1 b1 -> [(a1, b1)]
forall k a. Map k a -> [(k, a)]
M.toList Map a1 b1
f] [(Port (PortSorts a1 ++ PortSorts a1), b1)]
-> [(Port (PortSorts a1 ++ PortSorts a1), b1)]
-> [(Port (PortSorts a1 ++ PortSorts a1), b1)]
forall a. [a] -> [a] -> [a]
P.++ [(Int -> Port (PortSorts a1 ++ PortSorts a1)
forall s (xs :: [s]). Int -> Port xs
Port (Map a1 b1 -> Int
forall k a. Map k a -> Int
M.size Map a1 b1
f Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
j), b1
b1
x) | (Port Int
j, b1
x) <- Map a1 b1 -> [(a1, b1)]
forall k a. Map k a -> [(k, a)]
M.toList Map a1 b1
g]))
        )

-- | The pushout of 'FINHASK', whose apex is then renumbered as the ports of the sorts of its
-- elements, each of which comes from one of the two sides.
instance HasPushouts (SORTED s) where
  pushout :: forall (o :: SORTED s) (a :: SORTED s) (b :: SORTED s) r.
(o ~> a)
-> (o ~> b)
-> (forall (p :: SORTED s). (a ~> p) -> (b ~> p) -> r)
-> r
pushout (Sub @_ @_ @a FinHask a1 b1
f) (Sub @_ @_ @b FinHask a1 b1
g) forall (p :: SORTED s). (a ~> p) -> (b ~> p) -> r
k = (FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> (FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> (forall (p :: FINHASK).
    (FH (Port (PortSorts b1)) ~> p)
    -> (FH (Port (PortSorts b1)) ~> p) -> r)
-> r
forall k (o :: k) (a :: k) (b :: k) r.
HasPushouts k =>
(o ~> a)
-> (o ~> b) -> (forall (p :: k). (a ~> p) -> (b ~> p) -> r) -> r
forall (o :: FINHASK) (a :: FINHASK) (b :: FINHASK) r.
(o ~> a)
-> (o ~> b)
-> (forall (p :: FINHASK). (a ~> p) -> (b ~> p) -> r)
-> r
pushout FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
f FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
g \(FinHask Map a1 b1
l) (FinHask Map a1 b1
r) ->
    let
      sortA :: UN FH b1 -> SomeSort s
sortA = forall s (a :: FINHASK). Sorted s a => UN FH a -> SomeSort s
sortOf @s @a
      sortB :: UN FH b1 -> SomeSort s
sortB = forall s (a :: FINHASK). Sorted s a => UN FH a -> SomeSort s
sortOf @s @b
      nodeSorts :: Map b1 (SomeSort s)
nodeSorts = [(b1, SomeSort s)] -> Map b1 (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(b1
p, UN FH b1 -> SomeSort s
sortA a1
UN FH b1
x) | (a1
x, b1
p) <- Map a1 b1 -> [(a1, b1)]
forall k a. Map k a -> [(k, a)]
M.toList Map a1 b1
l] [(b1, SomeSort s)] -> [(b1, SomeSort s)] -> [(b1, SomeSort s)]
forall a. [a] -> [a] -> [a]
P.++ [(b1
b1
p, UN FH b1 -> SomeSort s
sortB a1
UN FH b1
y) | (a1
y, b1
p) <- Map a1 b1 -> [(a1, b1)]
forall k a. Map k a -> [(k, a)]
M.toList Map a1 b1
r])
      nodes :: [b1]
nodes = Map b1 (SomeSort s) -> [b1]
forall k a. Map k a -> [k]
M.keys Map b1 (SomeSort s)
nodeSorts
    in
      [SomeSort s] -> (forall (xs :: [s]). SortList xs => r) -> r
forall s r.
[SomeSort s] -> (forall (xs :: [s]). SortList xs => r) -> r
reifySorts (Map b1 (SomeSort s) -> [SomeSort s]
forall k a. Map k a -> [a]
M.elems Map b1 (SomeSort s)
nodeSorts) \ @xs ->
        let renumber :: Map b1 (Port xs)
renumber = [(b1, Port xs)] -> Map b1 (Port xs)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([b1] -> [Port xs] -> [(b1, Port xs)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [b1]
nodes ((Int -> Port xs) -> [Int] -> [Port xs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Port xs
forall s (xs :: [s]). Int -> Port xs
Port [Int
0 ..]))
        in (a ~> SUB (FH (Port xs))) -> (b ~> SUB (FH (Port xs))) -> r
forall (p :: SORTED s). (a ~> p) -> (b ~> p) -> r
k (FinHask (FH a1) (FH (Port xs))
-> Sub FinHask (SUB (FH a1)) (SUB (FH (Port xs)))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask @_ @(Port xs) ((b1 -> Port xs) -> Map a1 b1 -> Map a1 (Port xs)
forall a b. (a -> b) -> Map a1 a -> Map a1 b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map b1 (Port xs)
renumber Map b1 (Port xs) -> b1 -> Port xs
forall k a. Ord k => Map k a -> k -> a
M.!) Map a1 b1
l))) (FinHask (FH a1) (FH (Port xs))
-> Sub FinHask (SUB (FH a1)) (SUB (FH (Port xs)))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (Map a1 (Port xs) -> FinHask (FH a1) (FH (Port xs))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask ((b1 -> Port xs) -> Map a1 b1 -> Map a1 (Port xs)
forall a b. (a -> b) -> Map a1 a -> Map a1 b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map b1 (Port xs)
renumber Map b1 (Port xs) -> b1 -> Port xs
forall k a. Ord k => Map k a -> k -> a
M.!) Map a1 b1
Map a1 b1
r)))
  factorPushout :: forall (a :: SORTED s) (b :: SORTED s) (p :: SORTED s)
       (q :: SORTED s).
(a ~> p) -> (b ~> p) -> (a ~> q) -> (b ~> q) -> p ~> q
factorPushout (Sub FinHask a1 b1
p1) (Sub FinHask a1 b1
p2) (Sub FinHask a1 b1
k1) (Sub FinHask a1 b1
k2) = FinHask (FH (Port (PortSorts b1))) (FH (Port (PortSorts b1)))
-> Sub
     FinHask
     (SUB (FH (Port (PortSorts b1))))
     (SUB (FH (Port (PortSorts b1))))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub ((FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> (FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> (FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> (FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1)))
-> FH (Port (PortSorts b1)) ~> FH (Port (PortSorts b1))
forall k (a :: k) (b :: k) (p :: k) (q :: k).
HasPushouts k =>
(a ~> p) -> (b ~> p) -> (a ~> q) -> (b ~> q) -> p ~> q
forall (a :: FINHASK) (b :: FINHASK) (p :: FINHASK) (q :: FINHASK).
(a ~> p) -> (b ~> p) -> (a ~> q) -> (b ~> q) -> p ~> q
factorPushout FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
p1 FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
p2 FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
k1 FH (Port (PortSorts a1)) ~> FH (Port (PortSorts b1))
FinHask a1 b1
k2)

-- * Open hypergraphs

-- | A box with a label, attached to nodes of type @n@ by its inputs and its outputs.
type Box :: Type -> Type -> Type
data Box l n = Box {forall l n. Box l n -> l
label :: l, forall l n. Box l n -> [n]
inputs :: [n], forall l n. Box l n -> [n]
outputs :: [n]}
  deriving (Box l n -> Box l n -> Bool
(Box l n -> Box l n -> Bool)
-> (Box l n -> Box l n -> Bool) -> Eq (Box l n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall l n. (Eq l, Eq n) => Box l n -> Box l n -> Bool
$c== :: forall l n. (Eq l, Eq n) => Box l n -> Box l n -> Bool
== :: Box l n -> Box l n -> Bool
$c/= :: forall l n. (Eq l, Eq n) => Box l n -> Box l n -> Bool
/= :: Box l n -> Box l n -> Bool
P.Eq, Eq (Box l n)
Eq (Box l n) =>
(Box l n -> Box l n -> Ordering)
-> (Box l n -> Box l n -> Bool)
-> (Box l n -> Box l n -> Bool)
-> (Box l n -> Box l n -> Bool)
-> (Box l n -> Box l n -> Bool)
-> (Box l n -> Box l n -> Box l n)
-> (Box l n -> Box l n -> Box l n)
-> Ord (Box l n)
Box l n -> Box l n -> Bool
Box l n -> Box l n -> Ordering
Box l n -> Box l n -> Box l n
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
forall l n. (Ord l, Ord n) => Eq (Box l n)
forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Bool
forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Ordering
forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Box l n
$ccompare :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Ordering
compare :: Box l n -> Box l n -> Ordering
$c< :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Bool
< :: Box l n -> Box l n -> Bool
$c<= :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Bool
<= :: Box l n -> Box l n -> Bool
$c> :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Bool
> :: Box l n -> Box l n -> Bool
$c>= :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Bool
>= :: Box l n -> Box l n -> Bool
$cmax :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Box l n
max :: Box l n -> Box l n -> Box l n
$cmin :: forall l n. (Ord l, Ord n) => Box l n -> Box l n -> Box l n
min :: Box l n -> Box l n -> Box l n
P.Ord, Int -> Box l n -> ShowS
[Box l n] -> ShowS
Box l n -> String
(Int -> Box l n -> ShowS)
-> (Box l n -> String) -> ([Box l n] -> ShowS) -> Show (Box l n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall l n. (Show l, Show n) => Int -> Box l n -> ShowS
forall l n. (Show l, Show n) => [Box l n] -> ShowS
forall l n. (Show l, Show n) => Box l n -> String
$cshowsPrec :: forall l n. (Show l, Show n) => Int -> Box l n -> ShowS
showsPrec :: Int -> Box l n -> ShowS
$cshow :: forall l n. (Show l, Show n) => Box l n -> String
show :: Box l n -> String
$cshowList :: forall l n. (Show l, Show n) => [Box l n] -> ShowS
showList :: [Box l n] -> ShowS
P.Show, (forall a b. (a -> b) -> Box l a -> Box l b)
-> (forall a b. a -> Box l b -> Box l a) -> Functor (Box l)
forall a b. a -> Box l b -> Box l a
forall a b. (a -> b) -> Box l a -> Box l b
forall l a b. a -> Box l b -> Box l a
forall l a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall l a b. (a -> b) -> Box l a -> Box l b
fmap :: forall a b. (a -> b) -> Box l a -> Box l b
$c<$ :: forall l a b. a -> Box l b -> Box l a
<$ :: forall a b. a -> Box l b -> Box l a
P.Functor)

-- | Labelled boxes on the nodes of a sorted finite set. Two lists of boxes in a different order
-- describe the same hypergraph, which 'isomorphic' takes into account.
type Boxes :: Type -> SORTED s -> Type
data Boxes l c where
  Boxes :: [Box l n] -> Boxes l (SUB (FH n))

instance Functor (Boxes l :: SORTED s -> Type) where
  map :: forall (a :: SORTED s) (b :: SORTED s).
(a ~> b) -> Boxes l a ~> Boxes l b
map (Sub (FinHask Map a1 b1
m)) (Boxes [Box l n]
bs) = [Box l b1] -> Boxes l (SUB (FH b1))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes ((Box l a1 -> Box l b1) -> [Box l a1] -> [Box l b1]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((a1 -> b1) -> Box l a1 -> Box l b1
forall a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map a1 b1
m Map a1 b1 -> a1 -> b1
forall k a. Ord k => Map k a -> k -> a
M.!)) [Box l a1]
[Box l n]
bs)

-- | No boxes, and the boxes of both sides, the nodes of the second numbered after those of the first.
instance Alternative (Boxes l :: SORTED s -> Type) where
  empty :: forall (a :: SORTED s). Ob a => Unit ~> Boxes l a
empty () = [Box l (Port (PortSorts (FH (UN FH (UN SUB a)))))]
-> Boxes l (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB a)))))))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes []
  alt :: forall (a :: SORTED s) (b :: SORTED s) (c :: SORTED s).
(Ob a, Ob b) =>
((a || b) ~> c) -> (Boxes l a ** Boxes l b) ~> Boxes l c
alt @a (a || b) ~> c
h (Boxes [Box l n]
xs, Boxes [Box l n]
ys) =
    (SUB
   (FH
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b))))))
 ~> c)
-> Boxes
     l
     (SUB
        (FH
           (Port
              (PortSorts (FH (UN FH (UN SUB a)))
               ++ PortSorts (FH (UN FH (UN SUB b)))))))
   ~> Boxes l c
forall {k1} {k2} (f :: k1 -> k2) (a :: k1) (b :: k1).
Functor f =>
(a ~> b) -> f a ~> f b
forall (a :: SORTED s) (b :: SORTED s).
(a ~> b) -> Boxes l a ~> Boxes l b
map (a || b) ~> c
SUB
  (FH
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b))))))
~> c
h ([Box
   l
   (Port
      (PortSorts (FH (UN FH (UN SUB a)))
       ++ PortSorts (FH (UN FH (UN SUB b)))))]
-> Boxes
     l
     (SUB
        (FH
           (Port
              (PortSorts (FH (UN FH (UN SUB a)))
               ++ PortSorts (FH (UN FH (UN SUB b)))))))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes ((Box l (Port (PortSorts (FH (UN FH (UN SUB a)))))
 -> Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b))))))
-> [Box l (Port (PortSorts (FH (UN FH (UN SUB a)))))]
-> [Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b)))))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Port (PortSorts (FH (UN FH (UN SUB a))))
 -> Port
      (PortSorts (FH (UN FH (UN SUB a)))
       ++ PortSorts (FH (UN FH (UN SUB b)))))
-> Box l (Port (PortSorts (FH (UN FH (UN SUB a)))))
-> Box
     l
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b)))))
forall a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (\(Port Int
i) -> Int
-> Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b))))
forall s (xs :: [s]). Int -> Port xs
Port Int
i)) [Box l n]
[Box l (Port (PortSorts (FH (UN FH (UN SUB a)))))]
xs [Box
   l
   (Port
      (PortSorts (FH (UN FH (UN SUB a)))
       ++ PortSorts (FH (UN FH (UN SUB b)))))]
-> [Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b)))))]
-> [Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b)))))]
forall a. [a] -> [a] -> [a]
P.++ (Box l (Port (PortSorts (FH (UN FH (UN SUB b)))))
 -> Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b))))))
-> [Box l (Port (PortSorts (FH (UN FH (UN SUB b)))))]
-> [Box
      l
      (Port
         (PortSorts (FH (UN FH (UN SUB a)))
          ++ PortSorts (FH (UN FH (UN SUB b)))))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Port (PortSorts (FH (UN FH (UN SUB b))))
 -> Port
      (PortSorts (FH (UN FH (UN SUB a)))
       ++ PortSorts (FH (UN FH (UN SUB b)))))
-> Box l (Port (PortSorts (FH (UN FH (UN SUB b)))))
-> Box
     l
     (Port
        (PortSorts (FH (UN FH (UN SUB a)))
         ++ PortSorts (FH (UN FH (UN SUB b)))))
forall a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (\(Port Int
j) -> Int
-> Port
     (PortSorts (FH (UN FH (UN SUB a)))
      ++ PortSorts (FH (UN FH (UN SUB b))))
forall s (xs :: [s]). Int -> Port xs
Port (Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
j))) [Box l n]
[Box l (Port (PortSorts (FH (UN FH (UN SUB b)))))]
ys))
    where
      offset :: Int
offset = ListOf SortOb (PortSorts (FH (UN FH (UN SUB a)))) -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(PortSorts @s (UN SUB a)))

-- | Open hypergraphs with boxes labelled by @l@ and wires of sorts of kind @s@.
type OPENHG :: Kind -> Type -> Kind
type OPENHG s l = DECCOSPAN (Boxes l :: SORTED s -> Type)

-- | The boundary with a wire for each sort in the list.
type Wires :: forall s l. [s] -> OPENHG s l
type Wires xs = DC (SUB (FH (Port xs)))

-- | The sorts of the wires of a boundary.
type WireSorts :: forall s l. OPENHG s l -> [s]
type WireSorts a = PortSorts (UN SUB (UN DC a))

-- | One box with the given label, its inputs the wires of @as@ and its outputs those of @bs@: a
-- generator of the free hypergraph category.
box :: forall {s} l (as :: [s]) (bs :: [s]). (SortList as, SortList bs) => l -> Wires as ~> (Wires bs :: OPENHG s l)
box :: forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
l -> Wires as ~> Wires bs
box l
x =
  forall k (a :: k) (b :: k) r.
(HasBinaryCoproducts k, Ob a, Ob b) =>
(Ob (a || b) => r) -> r
withObCoprod @(SORTED s) @(SUB (FH (Port as))) @(SUB (FH (Port bs)))
    ( (SUB (FH (Port as)) ~> SUB (FH (Port (as ++ bs))))
-> (SUB (FH (Port bs)) ~> SUB (FH (Port (as ++ bs))))
-> Boxes l (SUB (FH (Port (as ++ bs))))
-> DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs))))
forall {k} {f :: k -> Type} (c :: k) (a1 :: k) (b1 :: k).
(a1 ~> c) -> (b1 ~> c) -> f c -> DecCospan (DC a1) (DC b1)
DecCospan
        (forall k (a :: k) (b :: k).
(HasBinaryCoproducts k, Ob a, Ob b) =>
a ~> (a || b)
lft @_ @(SUB (FH (Port as))) @(SUB (FH (Port bs))))
        (forall k (a :: k) (b :: k).
(HasBinaryCoproducts k, Ob a, Ob b) =>
b ~> (a || b)
rgt @_ @(SUB (FH (Port as))) @(SUB (FH (Port bs))))
        ([Box l (Port (as ++ bs))] -> Boxes l (SUB (FH (Port (as ++ bs))))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes [l
-> [Port (as ++ bs)]
-> [Port (as ++ bs)]
-> Box l (Port (as ++ bs))
forall l n. l -> [n] -> [n] -> Box l n
Box l
x (Int -> [Port (as ++ bs)] -> [Port (as ++ bs)]
forall a. Int -> [a] -> [a]
P.take Int
na [Port (as ++ bs)]
ports) (Int -> [Port (as ++ bs)] -> [Port (as ++ bs)]
forall a. Int -> [a] -> [a]
P.drop Int
na [Port (as ++ bs)]
ports)])
    )
  where
    na :: Int
na = ListOf SortOb as -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @as)
    ports :: [Port (as ++ bs)]
ports = (Int -> Port (as ++ bs)) -> [Int] -> [Port (as ++ bs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Port (as ++ bs)
forall s (xs :: [s]). Int -> Port xs
Port [Int
0 .. Int
na Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ ListOf SortOb bs -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @bs) Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1]

-- | The open hypergraph with the given nodes, boundaries and boxes. The first argument lists the
-- sorts of the nodes, and a node is referred to by its position in that list, counting from 0. The
-- second and third arguments give, for each wire of @as@ and of @bs@ in order, the node it is
-- attached to, and each box lists the nodes of its inputs and of its outputs. A node that occurs
-- several times joins all those wires and ports. Fails with a message unless every node referred
-- to exists and every wire has a sort isomorphic to that of its node.
--
-- The product of a box @a@ from @x@ to @y@ and a box @b@ from @y@ to @z@ has nodes of the sorts
-- @x@, @y@ and @z@, with @y@ shared between the boxes:
--
-- > openHypergraph @'[x] @'[z] [sx, sy, sz] [0] [2] [Box a [0] [1], Box b [1] [2]]
openHypergraph
  :: forall {s} l (as :: [s]) (bs :: [s])
   . (SortList as, SortList bs, DecidableIso s)
  => [SomeSort s]
  -> [P.Int]
  -> [P.Int]
  -> [Box l P.Int]
  -> P.Either P.String (Wires as ~> (Wires bs :: OPENHG s l))
openHypergraph :: forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs, DecidableIso s) =>
[SomeSort s]
-> [Int]
-> [Int]
-> [Box l Int]
-> Either String (Wires as ~> Wires bs)
openHypergraph [SomeSort s]
nodeSorts [Int]
ins [Int]
outs [Box l Int]
boxList
  | [Int] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Int]
ins Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P./= ListOf SortOb as -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @as) Bool -> Bool -> Bool
P.|| [Int] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Int]
outs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P./= ListOf SortOb bs -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @bs) =
      String
-> Either
     String
     (DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs)))))
forall a b. a -> Either a b
P.Left String
"openHypergraph: a boundary has a different number of wires than its sorts"
  | (Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.any
      (Int -> Map Int (SomeSort s) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.notMember` Map Int (SomeSort s)
sortAt)
      ([Int]
ins [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [Int]
outs [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [[Int]] -> [Int]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
P.concat [Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
bx [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs Box l Int
bx | Box l Int
bx <- [Box l Int]
boxList]) =
      String
-> Either
     String
     (DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs)))))
forall a b. a -> Either a b
P.Left String
"openHypergraph: a wire or box is attached to a node that does not exist"
  | Bool -> Bool
P.not
      ( Align s -> [SomeSort s] -> [SomeSort s] -> Bool
forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Maybe (Step '[x] '[y])
Align s
forall s. DecidableIso s => Align s
byIso ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
ins) (forall s (xs :: [s]). SortList xs => [SomeSort s]
sortList @s @as)
          Bool -> Bool -> Bool
P.&& Align s -> [SomeSort s] -> [SomeSort s] -> Bool
forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Maybe (Step '[x] '[y])
Align s
forall s. DecidableIso s => Align s
byIso ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
outs) (forall s (xs :: [s]). SortList xs => [SomeSort s]
sortList @s @bs)
      ) =
      String
-> Either
     String
     (DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs)))))
forall a b. a -> Either a b
P.Left String
"openHypergraph: a wire does not have the sort of its node"
  | Bool
P.otherwise = DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs))))
-> Either
     String
     (DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs)))))
forall a b. b -> Either a b
P.Right ([SomeSort s]
-> [Int]
-> [Int]
-> [Box l Int]
-> DC (SUB (FH (Port as))) ~> DC (SUB (FH (Port bs)))
forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
[SomeSort s]
-> [Int] -> [Int] -> [Box l Int] -> Wires as ~> Wires bs
unsafeOpenHypergraph [SomeSort s]
nodeSorts [Int]
ins [Int]
outs [Box l Int]
boxList)
  where
    sortAt :: Map Int (SomeSort s)
sortAt = [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [SomeSort s]
nodeSorts)

-- | 'openHypergraph' without its checks, with the same arguments: the boundaries must have as many
-- wires as their sorts, every wire and box must be attached to nodes that exist, and every wire must
-- have the sort of its node. Only for hypergraphs that satisfy this by construction, such as those
-- that 'simplify' is given, which trusts the sorts to be equal.
unsafeOpenHypergraph
  :: forall {s} l (as :: [s]) (bs :: [s])
   . (SortList as, SortList bs)
  => [SomeSort s]
  -> [P.Int]
  -> [P.Int]
  -> [Box l P.Int]
  -> Wires as ~> (Wires bs :: OPENHG s l)
unsafeOpenHypergraph :: forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
[SomeSort s]
-> [Int] -> [Int] -> [Box l Int] -> Wires as ~> Wires bs
unsafeOpenHypergraph [SomeSort s]
nodeSorts [Int]
ins [Int]
outs [Box l Int]
boxList = [SomeSort s]
-> (forall (xs :: [s]).
    SortList xs =>
    DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs)))))
-> DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs))))
forall s r.
[SomeSort s] -> (forall (xs :: [s]). SortList xs => r) -> r
reifySorts [SomeSort s]
nodeSorts \ @ns ->
  (SUB (FH (Port as)) ~> SUB (FH (Port xs)))
-> (SUB (FH (Port bs)) ~> SUB (FH (Port xs)))
-> Boxes l (SUB (FH (Port xs)))
-> DecCospan (DC (SUB (FH (Port as)))) (DC (SUB (FH (Port bs))))
forall {k} {f :: k -> Type} (c :: k) (a1 :: k) (b1 :: k).
(a1 ~> c) -> (b1 ~> c) -> f c -> DecCospan (DC a1) (DC b1)
DecCospan
    (FinHask (FH (Port as)) (FH (Port xs))
-> Sub FinHask (SUB (FH (Port as))) (SUB (FH (Port xs)))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (Map (Port as) (Port xs) -> FinHask (FH (Port as)) (FH (Port xs))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask ([(Port as, Port xs)] -> Map (Port as) (Port xs)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Port as] -> [Port xs] -> [(Port as, Port xs)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Port as]
forall a. Finite a => [a]
universeF ((Int -> Port xs) -> [Int] -> [Port xs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (forall s (xs :: [s]). Int -> Port xs
Port @_ @ns) [Int]
ins)))))
    (FinHask (FH (Port bs)) (FH (Port xs))
-> Sub FinHask (SUB (FH (Port bs))) (SUB (FH (Port xs)))
forall {k} (ob :: OB k) (a1 :: k) (b1 :: k) (p :: CAT k).
(ob a1, ob b1) =>
p a1 b1 -> Sub p (SUB a1) (SUB b1)
Sub (Map (Port bs) (Port xs) -> FinHask (FH (Port bs)) (FH (Port xs))
forall a1 b1.
(Ob (FH a1), Ob (FH b1)) =>
Map a1 b1 -> FinHask (FH a1) (FH b1)
FinHask ([(Port bs, Port xs)] -> Map (Port bs) (Port xs)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Port bs] -> [Port xs] -> [(Port bs, Port xs)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Port bs]
forall a. Finite a => [a]
universeF ((Int -> Port xs) -> [Int] -> [Port xs]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (forall s (xs :: [s]). Int -> Port xs
Port @_ @ns) [Int]
outs)))))
    ([Box l (Port xs)] -> Boxes l (SUB (FH (Port xs)))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes ((Box l Int -> Box l (Port xs)) -> [Box l Int] -> [Box l (Port xs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Int -> Port xs) -> Box l Int -> Box l (Port xs)
forall a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Port xs
forall s (xs :: [s]). Int -> Port xs
Port) [Box l Int]
boxList))

-- | An open hypergraph whose boundaries are known at runtime, for replacing a labelled box.
type SomeHypergraph :: Kind -> Type -> Type
data SomeHypergraph s l where
  SomeHypergraph :: (a :: OPENHG s l) ~> b -> SomeHypergraph s l

-- | Replace every box by the diagram assigned to its label. Each replacement must have as many
-- inputs and outputs as the box, in the same order, with isomorphic sorts. All replacements are
-- glued together in one union-find pass. Shared nodes, repeated ports and isolated nodes are kept.
-- Replacement labels are not substituted again.
--
-- Adapted from the functor-application construction in §9 of Wilson and Zanasi,
-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>, restricted to an
-- identity object map. This implementation uses maps and union-find rather than the paper's
-- data-parallel representation.
substitute
  :: forall {s} l m a b
   . (DecidableIso s)
  => (l -> SomeHypergraph s m)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (Wires (WireSorts a) ~> (Wires (WireSorts b) :: OPENHG s m))
substitute :: forall {s} l m (a :: OPENHG s l) (b :: OPENHG s l).
DecidableIso s =>
(l -> SomeHypergraph s m)
-> (a ~> b)
-> Either String (Wires (WireSorts a) ~> Wires (WireSorts b))
substitute l -> SomeHypergraph s m
replace a ~> b
hg =
  a ~> b
DecCospan a b
hg DecCospan a b
-> ((Ob a, Ob b) =>
    Either
      String
      (DecCospan
         (DC (SUB (FH (Port (PortSorts (UN SUB (UN DC a)))))))
         (DC (SUB (FH (Port (PortSorts (UN SUB (UN DC b)))))))))
-> Either
     String
     (DecCospan
        (DC (SUB (FH (Port (PortSorts (UN SUB (UN DC a)))))))
        (DC (SUB (FH (Port (PortSorts (UN SUB (UN DC b))))))))
forall {k1} {k2} (p :: k1 +-> k2) (a :: k2) (b :: k1) r.
Profunctor p =>
p a b -> ((Ob a, Ob b) => r) -> r
// do
    (nodes, ins, outs, boxes) <- Align s
-> (l -> SomeHypergraph s m)
-> ([SomeSort s], [Int], [Int], [Box l Int])
-> Either String ([SomeSort s], [Int], [Int], [Box m Int])
forall {s} l m.
Align s
-> (l -> SomeHypergraph s m)
-> ([SomeSort s], [Int], [Int], [Box l Int])
-> Either String ([SomeSort s], [Int], [Int], [Box m Int])
substituteParts Maybe (Step '[x] '[y])
Align s
forall s. DecidableIso s => Align s
byIso l -> SomeHypergraph s m
replace ((DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC a))))))))
 ~> DC
      (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC b)))))))))
-> ([SomeSort s], [Int], [Int], [Box l Int])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
hypergraphParts a ~> b
DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC a))))))))
~> DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC b))))))))
hg)
    P.pure (unsafeOpenHypergraph nodes ins outs boxes)

-- | Apply an object map and a generator map to an open hypergraph. Each source sort becomes a list
-- of target sorts, and each box is replaced by a diagram with the expanded inputs and outputs.
-- Every occurrence of a node uses the same expanded nodes, including repeated ports and boundaries.
-- An empty list removes a node; an isolated node expands to one isolated node per target sort.
-- The resulting boundaries are known at runtime, so the result is a 'SomeHypergraph'.
--
-- The object map must send isomorphic source sorts to lists of pairwise isomorphic target sorts
-- for composition to be preserved. Replacement boundaries are checked as in 'substitute'.
--
-- Adapted from the functor-application construction in §9 of Wilson and Zanasi,
-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>.
-- This implementation uses lists, maps and union-find rather than the paper's data-parallel representation.
substituteWith
  :: forall {s} {t} l m a b
   . (DecidableIso t)
  => (SomeSort s -> [SomeSort t])
  -> (l -> SomeHypergraph t m)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (SomeHypergraph t m)
substituteWith :: forall {s} {t} l m (a :: OPENHG s l) (b :: OPENHG s l).
DecidableIso t =>
(SomeSort s -> [SomeSort t])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
substituteWith = Align t
-> (SomeOf Ob' -> [SomeOf Ob'])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
forall {s} {t} l m (a :: OPENHG s l) (b :: OPENHG s l).
Align t
-> (SomeSort s -> [SomeSort t])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
substituteWithAligned Maybe (Step '[x] '[y])
Align t
forall s. DecidableIso s => Align s
byIso

-- | 'substituteWith' without comparing sorts. Replacement boundaries must have the sorts
-- specified by the object map, in order. Arity is still checked. For typed primitive translations
-- whose source and replacement ports agree by construction; otherwise use 'substituteWith'.
unsafeSubstituteWith
  :: forall {s} {t} l m a b
   . (SomeSort s -> [SomeSort t])
  -> (l -> SomeHypergraph t m)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (SomeHypergraph t m)
unsafeSubstituteWith :: forall {s} {t} l m (a :: OPENHG s l) (b :: OPENHG s l).
(SomeSort s -> [SomeSort t])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
unsafeSubstituteWith = Align t
-> (SomeOf Ob' -> [SomeOf Ob'])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
forall {s} {t} l m (a :: OPENHG s l) (b :: OPENHG s l).
Align t
-> (SomeSort s -> [SomeSort t])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
substituteWithAligned Maybe (Step '[x] '[y])
Align t
forall s (x :: s) (y :: s). (Ob x, Ob y) => Maybe (Step '[x] '[y])
trusted

substituteWithAligned
  :: forall {s} {t} l m a b
   . Align t
  -> (SomeSort s -> [SomeSort t])
  -> (l -> SomeHypergraph t m)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (SomeHypergraph t m)
substituteWithAligned :: forall {s} {t} l m (a :: OPENHG s l) (b :: OPENHG s l).
Align t
-> (SomeSort s -> [SomeSort t])
-> (l -> SomeHypergraph t m)
-> (a ~> b)
-> Either String (SomeHypergraph t m)
substituteWithAligned Align t
al SomeSort s -> [SomeSort t]
mapSort l -> SomeHypergraph t m
replace a ~> b
hg = do
  let ([SomeSort s]
original, [Int]
ins, [Int]
outs, [Box l Int]
boxes) = (a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
hypergraphParts a ~> b
hg
      expanded :: [[SomeSort t]]
expanded = (SomeSort s -> [SomeSort t]) -> [SomeSort s] -> [[SomeSort t]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap SomeSort s -> [SomeSort t]
mapSort [SomeSort s]
original
      sizes :: [Int]
sizes = ([SomeSort t] -> Int) -> [[SomeSort t]] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap [SomeSort t] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [[SomeSort t]]
expanded
      offsets :: [Int]
offsets = (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
P.scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) Int
0 [Int]
sizes
      segments :: Map Int [Int]
segments = [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [[Int]] -> [(Int, [Int])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] ((Int -> Int -> [Int]) -> [Int] -> [Int] -> [[Int]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
P.zipWith (\Int
offset Int
n -> [Int
offset .. Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1]) [Int]
offsets [Int]
sizes))
      ports :: [Int] -> [Int]
ports = (Int -> [Int]) -> [Int] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap (Map Int [Int]
segments Map Int [Int] -> Int -> [Int]
forall k a. Ord k => Map k a -> k -> a
M.!)
  (nodes, inputs', outputs', boxes') <-
    Align t
-> (l -> SomeHypergraph t m)
-> ([SomeSort t], [Int], [Int], [Box l Int])
-> Either String ([SomeSort t], [Int], [Int], [Box m Int])
forall {s} l m.
Align s
-> (l -> SomeHypergraph s m)
-> ([SomeSort s], [Int], [Int], [Box l Int])
-> Either String ([SomeSort s], [Int], [Int], [Box m Int])
substituteParts
      Maybe (Step '[x] '[y])
Align t
al
      l -> SomeHypergraph t m
replace
      ([[SomeSort t]] -> [SomeSort t]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
P.concat [[SomeSort t]]
expanded, [Int] -> [Int]
ports [Int]
ins, [Int] -> [Int]
ports [Int]
outs, [l -> [Int] -> [Int] -> Box l Int
forall l n. l -> [n] -> [n] -> Box l n
Box l
x ([Int] -> [Int]
ports [Int]
i) ([Int] -> [Int]
ports [Int]
o) | Box l
x [Int]
i [Int]
o <- [Box l Int]
boxes])
  let sortAt = [(Int, SomeSort t)] -> Map Int (SomeSort t)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort t] -> [(Int, SomeSort t)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [SomeSort t]
nodes)
  reifySorts (P.fmap (sortAt M.!) inputs') \ @as ->
    [SomeSort t]
-> (forall (xs :: [t]).
    SortList xs =>
    Either String (SomeHypergraph t m))
-> Either String (SomeHypergraph t m)
forall s r.
[SomeSort s] -> (forall (xs :: [s]). SortList xs => r) -> r
reifySorts ((Int -> SomeSort t) -> [Int] -> [SomeSort t]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int (SomeSort t)
sortAt Map Int (SomeSort t) -> Int -> SomeSort t
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
outputs') \ @bs ->
      SomeHypergraph t m -> Either String (SomeHypergraph t m)
forall a. a -> Either String a
forall (f :: Type -> Type) a. Applicative f => a -> f a
P.pure ((Wires xs ~> Wires xs) -> SomeHypergraph t m
forall s l (ys :: OPENHG s l) (bs :: OPENHG s l).
(ys ~> bs) -> SomeHypergraph s l
SomeHypergraph (forall l (as :: [t]) (bs :: [t]).
(SortList as, SortList bs) =>
[SomeSort t]
-> [Int] -> [Int] -> [Box l Int] -> Wires as ~> Wires bs
forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
[SomeSort s]
-> [Int] -> [Int] -> [Box l Int] -> Wires as ~> Wires bs
unsafeOpenHypergraph @m @as @bs [SomeSort t]
nodes [Int]
inputs' [Int]
outputs' [Box m Int]
boxes'))

substituteParts
  :: forall {s} l m
   . Align s
  -> (l -> SomeHypergraph s m)
  -> ([SomeSort s], [P.Int], [P.Int], [Box l P.Int])
  -> P.Either P.String ([SomeSort s], [P.Int], [P.Int], [Box m P.Int])
substituteParts :: forall {s} l m.
Align s
-> (l -> SomeHypergraph s m)
-> ([SomeSort s], [Int], [Int], [Box l Int])
-> Either String ([SomeSort s], [Int], [Int], [Box m Int])
substituteParts Align s
al l -> SomeHypergraph s m
replace ([SomeSort s]
original, [Int]
ins, [Int]
outs, [Box l Int]
bs) = do
  let sortAt :: Map Int (SomeSort s)
sortAt = [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [SomeSort s]
original)
      add :: (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
-> Box l Int
-> Either
     String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
add (Int
offset, [[SomeSort s]]
ns, [[Box m Int]]
boxes, [[(Int, Int)]]
joins) (Box l
x [Int]
i [Int]
o) =
        case l -> SomeHypergraph s m
replace l
x of
          SomeHypergraph a ~> b
replacement ->
            let ([SomeSort s]
nodes, [Int]
ri, [Int]
ro, [Box m Int]
rb) = (a ~> b) -> ([SomeSort s], [Int], [Int], [Box m Int])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
hypergraphParts a ~> b
replacement
                replacementSorts :: Map Int (SomeSort s)
replacementSorts = [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [SomeSort s]
nodes)
                matches :: [Int] -> [Int] -> Bool
matches [Int]
ports [Int]
boundary =
                  Align s -> [SomeSort s] -> [SomeSort s] -> Bool
forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Maybe (Step '[x] '[y])
Align s
al ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
ports) ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int (SomeSort s)
replacementSorts Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!) [Int]
boundary)
                shift :: Int -> Int
shift Int
n = Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
n
            in if [Int] -> [Int] -> Bool
matches [Int]
i [Int]
ri Bool -> Bool -> Bool
P.&& [Int] -> [Int] -> Bool
matches [Int]
o [Int]
ro
                 then
                   (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
-> Either
     String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
forall a b. b -> Either a b
P.Right
                     ( Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ [SomeSort s] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [SomeSort s]
nodes
                     , [SomeSort s]
nodes [SomeSort s] -> [[SomeSort s]] -> [[SomeSort s]]
forall a. a -> [a] -> [a]
: [[SomeSort s]]
ns
                     , (Box m Int -> Box m Int) -> [Box m Int] -> [Box m Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Int -> Int) -> Box m Int -> Box m Int
forall a b. (a -> b) -> Box m a -> Box m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Int
shift) [Box m Int]
rb [Box m Int] -> [[Box m Int]] -> [[Box m Int]]
forall a. a -> [a] -> [a]
: [[Box m Int]]
boxes
                     , ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int]
i ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Int
shift [Int]
ri) [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
P.++ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int]
o ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Int
shift [Int]
ro)) [(Int, Int)] -> [[(Int, Int)]] -> [[(Int, Int)]]
forall a. a -> [a] -> [a]
: [[(Int, Int)]]
joins
                     )
                 else String
-> Either
     String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
forall a b. a -> Either a b
P.Left String
"substitute: a replacement boundary has different arity or sorts"
  (nodeCount, chunks, boxes, joins) <- ((Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
 -> Box l Int
 -> Either
      String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]]))
-> (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
-> [Box l Int]
-> Either
     String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
-> Box l Int
-> Either
     String (Int, [[SomeSort s]], [[Box m Int]], [[(Int, Int)]])
add ([SomeSort s] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [SomeSort s]
original, [[SomeSort s]
original], [], []) [Box l Int]
bs
  let nodeSorts = [[SomeSort s]] -> [SomeSort s]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
P.concat ([[SomeSort s]] -> [[SomeSort s]]
forall a. [a] -> [a]
P.reverse [[SomeSort s]]
chunks)
      root = [(Int, Int)] -> Int -> Int
forall a. Ord a => [(a, a)] -> a -> a
unionFind ([[(Int, Int)]] -> [(Int, Int)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
P.concat [[(Int, Int)]]
joins)
      roots = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
n, Int -> Int
root Int
n) | Int
n <- [Int
0 .. Int
nodeCount Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1]]
      quotient = [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (Map Int Int -> [Int]
forall k a. Map k a -> [a]
M.elems Map Int Int
roots) [SomeSort s]
nodeSorts)
      indices = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (Map Int (SomeSort s) -> [Int]
forall k a. Map k a -> [k]
M.keys Map Int (SomeSort s)
quotient) [Int
0 ..])
      renumber = Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
(M.!) ((Int -> Int) -> Map Int Int -> Map Int Int
forall a b. (a -> b) -> Map Int a -> Map Int b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map Int Int
indices Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) Map Int Int
roots)
  P.pure
    ( M.elems quotient
    , P.fmap renumber ins
    , P.fmap renumber outs
    , P.fmap (P.fmap renumber) (P.concat (P.reverse boxes))
    )

hypergraphParts :: forall {s} l a b. (a :: OPENHG s l) ~> b -> ([SomeSort s], [P.Int], [P.Int], [Box l P.Int])
hypergraphParts :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
hypergraphParts (DecCospan @c (Sub (FinHask Map a1 b1
l)) (Sub (FinHask Map a1 b1
r)) (Boxes [Box l n]
bs)) =
  ( forall s (xs :: [s]). SortList xs => [SomeSort s]
sortList @s @(PortSorts @s (UN SUB c))
  , (Port (PortSorts b1) -> Int) -> [Port (PortSorts b1)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Port (PortSorts b1) -> Int
forall {s} {xs :: [s]}. Port xs -> Int
unPort (Map a1 (Port (PortSorts b1)) -> [Port (PortSorts b1)]
forall k a. Map k a -> [a]
M.elems Map a1 b1
Map a1 (Port (PortSorts b1))
l)
  , (Port (PortSorts b1) -> Int) -> [Port (PortSorts b1)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Port (PortSorts b1) -> Int
forall {s} {xs :: [s]}. Port xs -> Int
unPort (Map a1 (Port (PortSorts b1)) -> [Port (PortSorts b1)]
forall k a. Map k a -> [a]
M.elems Map a1 b1
Map a1 (Port (PortSorts b1))
r)
  , (Box l (Port (PortSorts b1)) -> Box l Int)
-> [Box l (Port (PortSorts b1))] -> [Box l Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Port (PortSorts b1) -> Int)
-> Box l (Port (PortSorts b1)) -> Box l Int
forall a b. (a -> b) -> Box l a -> Box l b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Port (PortSorts b1) -> Int
forall {s} {xs :: [s]}. Port xs -> Int
unPort) [Box l n]
[Box l (Port (PortSorts b1))]
bs
  )
  where
    unPort :: Port xs -> Int
unPort (Port Int
i) = Int
i

-- | Whether two open hypergraphs differ only in the names of their nodes, the order of their boxes
-- and their sorts up to isomorphism: a bijection between the nodes that keeps their sorts, agrees
-- with both boundaries and takes the boxes of one to those of the other.
isomorphic :: forall {s} l a b. (P.Eq l, DecidableIso s) => (a :: OPENHG s l) ~> b -> a ~> b -> P.Bool
isomorphic :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(Eq l, DecidableIso s) =>
(a ~> b) -> (a ~> b) -> Bool
isomorphic
  (DecCospan @c1 (Sub (FinHask Map a1 b1
l1)) (Sub (FinHask Map a1 b1
r1)) (Boxes [Box l n]
bs1))
  (DecCospan @c2 (Sub (FinHask Map a1 b1
l2)) (Sub (FinHask Map a1 b1
r2)) (Boxes [Box l n]
bs2)) =
    -- the nodes that nothing is attached to can be matched up exactly when this holds
    (SomeSort s -> SomeSort s -> Bool)
-> [SomeSort s] -> [SomeSort s] -> Bool
forall {t} {a}. (t -> a -> Bool) -> [t] -> [a] -> Bool
sameBag SomeSort s -> SomeSort s -> Bool
forall s. DecidableIso s => SomeSort s -> SomeSort s -> Bool
sameSort ((Port (PortSorts b1) -> SomeSort s)
-> [Port (PortSorts b1)] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap UN FH (UN SUB c) -> SomeSort s
Port (PortSorts b1) -> SomeSort s
sort1 [UN FH (UN SUB c)]
[Port (PortSorts b1)]
nodes1) ((Port (PortSorts b1) -> SomeSort s)
-> [Port (PortSorts b1)] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap UN FH (UN SUB c) -> SomeSort s
Port (PortSorts b1) -> SomeSort s
sort2 [UN FH (UN SUB c)]
[Port (PortSorts b1)]
nodes2)
      Bool -> Bool -> Bool
P.&& ((l, Int, Int) -> (l, Int, Int) -> Bool)
-> [(l, Int, Int)] -> [(l, Int, Int)] -> Bool
forall {t} {a}. (t -> a -> Bool) -> [t] -> [a] -> Bool
sameBag (l, Int, Int) -> (l, Int, Int) -> Bool
forall a. Eq a => a -> a -> Bool
(P.==) ((Box l n -> (l, Int, Int)) -> [Box l n] -> [(l, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Box l n -> (l, Int, Int)
forall {a} {a}. Box a a -> (a, Int, Int)
shape [Box l n]
bs1) ((Box l n -> (l, Int, Int)) -> [Box l n] -> [(l, Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Box l n -> (l, Int, Int)
forall {a} {a}. Box a a -> (a, Int, Int)
shape [Box l n]
bs2)
      Bool -> Bool -> Bool
P.&& Maybe (Map b1 b1, Map b1 b1) -> Bool
forall a. Maybe a -> Bool
isJust
        ((Map b1 b1, Map b1 b1)
-> [(b1, b1)] -> Maybe (Map b1 b1, Map b1 b1)
extendAll (Map b1 b1
forall k a. Map k a
M.empty, Map b1 b1
forall k a. Map k a
M.empty) ([b1] -> [b1] -> [(b1, b1)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (Map a1 b1 -> [b1]
forall k a. Map k a -> [a]
M.elems Map a1 b1
l1) (Map a1 b1 -> [b1]
forall k a. Map k a -> [a]
M.elems Map a1 b1
l2) [(b1, b1)] -> [(b1, b1)] -> [(b1, b1)]
forall a. [a] -> [a] -> [a]
P.++ [b1] -> [b1] -> [(b1, b1)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip (Map a1 b1 -> [b1]
forall k a. Map k a -> [a]
M.elems Map a1 b1
Map a1 b1
r1) (Map a1 b1 -> [b1]
forall k a. Map k a -> [a]
M.elems Map a1 b1
Map a1 b1
r2)) Maybe (Map b1 b1, Map b1 b1)
-> ((Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1))
-> Maybe (Map b1 b1, Map b1 b1)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
P.>>= [Box l b1]
-> [Box l b1]
-> (Map b1 b1, Map b1 b1)
-> Maybe (Map b1 b1, Map b1 b1)
boxes [Box l b1]
[Box l n]
bs1 [Box l b1]
[Box l n]
bs2)
    where
      nodes1 :: [UN FH (UN SUB c)]
nodes1 = forall a. Finite a => [a]
universeF @(UN FH (UN SUB c1))
      nodes2 :: [UN FH (UN SUB c)]
nodes2 = forall a. Finite a => [a]
universeF @(UN FH (UN SUB c2))
      sort1 :: UN FH (UN SUB c) -> SomeSort s
sort1 = forall s (a :: FINHASK). Sorted s a => UN FH a -> SomeSort s
sortOf @s @(UN SUB c1)
      sort2 :: UN FH (UN SUB c) -> SomeSort s
sort2 = forall s (a :: FINHASK). Sorted s a => UN FH a -> SomeSort s
sortOf @s @(UN SUB c2)
      shape :: Box a a -> (a, Int, Int)
shape (Box a
x [a]
i [a]
o) = (a
x, [a] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [a]
i, [a] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [a]
o)
      -- the same elements, counted with multiplicity
      sameBag :: (t -> a -> Bool) -> [t] -> [a] -> Bool
sameBag t -> a -> Bool
_ [] [a]
ys = [a] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
P.null [a]
ys
      sameBag t -> a -> Bool
eq (t
x : [t]
xs) [a]
ys = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.break (t -> a -> Bool
eq t
x) [a]
ys of
        ([a]
_, []) -> Bool
P.False
        ([a]
before, a
_ : [a]
after) -> (t -> a -> Bool) -> [t] -> [a] -> Bool
sameBag t -> a -> Bool
eq [t]
xs ([a]
before [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
P.++ [a]
after)
      boxes :: [Box l b1]
-> [Box l b1]
-> (Map b1 b1, Map b1 b1)
-> Maybe (Map b1 b1, Map b1 b1)
boxes [] [Box l b1]
_ (Map b1 b1, Map b1 b1)
m = (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1)
forall a. a -> Maybe a
P.Just (Map b1 b1, Map b1 b1)
m
      boxes (Box l b1
x : [Box l b1]
xs) [Box l b1]
ys (Map b1 b1, Map b1 b1)
m = [Maybe (Map b1 b1, Map b1 b1)] -> Maybe (Map b1 b1, Map b1 b1)
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum [Box l b1
-> Box l b1
-> (Map b1 b1, Map b1 b1)
-> Maybe (Map b1 b1, Map b1 b1)
match Box l b1
x Box l b1
y (Map b1 b1, Map b1 b1)
m Maybe (Map b1 b1, Map b1 b1)
-> ((Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1))
-> Maybe (Map b1 b1, Map b1 b1)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
P.>>= [Box l b1]
-> [Box l b1]
-> (Map b1 b1, Map b1 b1)
-> Maybe (Map b1 b1, Map b1 b1)
boxes [Box l b1]
xs [Box l b1]
rest | (Box l b1
y, [Box l b1]
rest) <- [Box l b1] -> [(Box l b1, [Box l b1])]
forall x. [x] -> [(x, [x])]
picks [Box l b1]
ys]
      match :: Box l b1
-> Box l b1
-> (Map b1 b1, Map b1 b1)
-> Maybe (Map b1 b1, Map b1 b1)
match (Box l
lx [b1]
ix [b1]
ox) (Box l
ly [b1]
iy [b1]
oy) (Map b1 b1, Map b1 b1)
m
        | l
lx l -> l -> Bool
forall a. Eq a => a -> a -> Bool
P.== l
ly Bool -> Bool -> Bool
P.&& [b1] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [b1]
ix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== [b1] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [b1]
iy Bool -> Bool -> Bool
P.&& [b1] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [b1]
ox Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== [b1] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [b1]
oy =
            (Map b1 b1, Map b1 b1)
-> [(b1, b1)] -> Maybe (Map b1 b1, Map b1 b1)
extendAll (Map b1 b1, Map b1 b1)
m ([b1] -> [b1] -> [(b1, b1)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [b1]
ix [b1]
iy [(b1, b1)] -> [(b1, b1)] -> [(b1, b1)]
forall a. [a] -> [a] -> [a]
P.++ [b1] -> [b1] -> [(b1, b1)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [b1]
ox [b1]
oy)
        | Bool
P.otherwise = Maybe (Map b1 b1, Map b1 b1)
forall a. Maybe a
P.Nothing
      extendAll :: (Map b1 b1, Map b1 b1)
-> [(b1, b1)] -> Maybe (Map b1 b1, Map b1 b1)
extendAll = ((Map b1 b1, Map b1 b1)
 -> (b1, b1) -> Maybe (Map b1 b1, Map b1 b1))
-> (Map b1 b1, Map b1 b1)
-> [(b1, b1)]
-> Maybe (Map b1 b1, Map b1 b1)
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (((b1, b1)
 -> (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1))
-> (Map b1 b1, Map b1 b1)
-> (b1, b1)
-> Maybe (Map b1 b1, Map b1 b1)
forall a b c. (a -> b -> c) -> b -> a -> c
P.flip (b1, b1) -> (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1)
extend)
      extend :: (b1, b1) -> (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1)
extend (b1
x, b1
y) (Map b1 b1
fwd, Map b1 b1
bwd)
        | Bool -> Bool
P.not (SomeSort s -> SomeSort s -> Bool
forall s. DecidableIso s => SomeSort s -> SomeSort s -> Bool
sameSort (UN FH (UN SUB c) -> SomeSort s
sort1 b1
UN FH (UN SUB c)
x) (UN FH (UN SUB c) -> SomeSort s
sort2 b1
UN FH (UN SUB c)
y)) = Maybe (Map b1 b1, Map b1 b1)
forall a. Maybe a
P.Nothing
        | Bool
P.otherwise = case (b1 -> Map b1 b1 -> Maybe b1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup b1
x Map b1 b1
fwd, b1 -> Map b1 b1 -> Maybe b1
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup b1
y Map b1 b1
bwd) of
            (Maybe b1
P.Nothing, Maybe b1
P.Nothing) -> (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1)
forall a. a -> Maybe a
P.Just (b1 -> b1 -> Map b1 b1 -> Map b1 b1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert b1
x b1
y Map b1 b1
fwd, b1 -> b1 -> Map b1 b1 -> Map b1 b1
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert b1
y b1
x Map b1 b1
bwd)
            (P.Just b1
y', P.Just b1
x') | b1
y' b1 -> b1 -> Bool
forall a. Eq a => a -> a -> Bool
P.== b1
y Bool -> Bool -> Bool
P.&& b1
x' b1 -> b1 -> Bool
forall a. Eq a => a -> a -> Bool
P.== b1
x -> (Map b1 b1, Map b1 b1) -> Maybe (Map b1 b1, Map b1 b1)
forall a. a -> Maybe a
P.Just (Map b1 b1
fwd, Map b1 b1
bwd)
            (Maybe b1, Maybe b1)
_ -> Maybe (Map b1 b1, Map b1 b1)
forall a. Maybe a
P.Nothing
      picks :: [x] -> [(x, [x])]
      picks :: forall x. [x] -> [(x, [x])]
picks [x]
xs = [(x
x, [x]
before [x] -> [x] -> [x]
forall a. [a] -> [a] -> [a]
P.++ [x]
after) | ([x]
before, x
x : [x]
after) <- [[x]] -> [[x]] -> [([x], [x])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip ([x] -> [[x]]
forall a. [a] -> [[a]]
List.inits [x]
xs) ([x] -> [[x]]
forall a. [a] -> [[a]]
List.tails [x]
xs)]

-- * Read-back

-- | An arrow of the strictified category of @s@ whose lists of sorts are known at runtime, such as
-- the interpretation of a box.
type SomeArrow :: Kind -> Type
data SomeArrow s where
  SomeArrow :: forall {s} (as :: [s]) bs. Sorts as -> Sorts bs -> as ~> bs -> SomeArrow s

-- | An arrow as one whose sorts are known at runtime.
someArrow :: forall {s} (as :: [s]) bs. (SortList as, SortList bs) => as ~> bs -> SomeArrow s
someArrow :: forall {s} (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
(as ~> bs) -> SomeArrow s
someArrow = Sorts as -> Sorts bs -> (as ~> bs) -> SomeArrow s
forall {s} (ys :: [s]) (bs :: [s]).
Sorts ys -> Sorts bs -> (ys ~> bs) -> SomeArrow s
SomeArrow (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @as) (forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @bs)

-- | Wiring operations, feedback and box scheduling. 'permutations' and 'copyDiscard' reject
-- cycles; 'frobenius' supplies its cup-and-cap trace. 'tracedWith' replaces the feedback policy
-- with the target's trace while keeping the wiring operations and contraction plan.
-- Read-back reduces estimated swap cost; 'layered' also places independent boxes side by side.
type Wiring :: Kind -> Type
data Wiring s = Wiring
  { forall s. Wiring s -> Feedback s
wiringFeedback :: Feedback s
  , forall s. Wiring s -> Scheduling
wiringScheduling :: Scheduling
  , forall s. Wiring s -> Maybe (SomeSort s -> Int)
wiringSize :: P.Maybe (SomeSort s -> P.Int)
  , forall s.
Wiring s
-> forall l (a :: OPENHG s l) (b :: OPENHG s l).
   Align s
   -> Feedback s
   -> Scheduling
   -> (SomeSort s -> Int)
   -> (l -> SomeArrow s)
   -> (a ~> b)
   -> Either String (WireSorts a ~> WireSorts b)
runWiring
      :: forall l a b
       . Align s
      -> Feedback s
      -> Scheduling
      -> (SomeSort s -> P.Int)
      -> (l -> SomeArrow s)
      -> (a :: OPENHG s l) ~> b
      -> P.Either P.String (WireSorts a ~> WireSorts b)
  }

-- | Only permutations: every node has one producer and one consumer. Nullary boxes and scalars
-- are allowed; copying, merging and discarding need stronger wiring operations. With 'tracedWith',
-- isolated loops are traced identities.
permutations :: (SymMonoidal s) => Wiring s
permutations :: forall s. SymMonoidal s => Wiring s
permutations = Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
forall s.
Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
Wiring Feedback s
forall s. Feedback s
acyclic Scheduling
Sequential Maybe (SomeSort s -> Int)
forall a. Maybe a
P.Nothing (\Align s
al Feedback s
fb Scheduling
mode SomeSort s -> Int
sizeFn -> Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (Int -> Bool)
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
SymMonoidal s =>
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (Int -> Bool)
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBackDirected Maybe (Step '[x] '[y])
Align s
al Feedback s
fb Scheduling
mode SomeSort s -> Int
sizeFn (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
1) [Key] -> [Key] -> Built xs -> Built xs
forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs
forall {s} {a} {xs :: [s]}.
(Ord a, SymMonoidal s) =>
[a] -> [a] -> Built xs -> Built xs
permuteWires)
  where
    permuteWires :: [a] -> [a] -> Built xs -> Built xs
permuteWires [a]
bundle [a]
wanted =
      let positions :: Map a Int
positions = [(a, Int)] -> Map a Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [a]
bundle [Int
0 ..])
      in [Int] -> Built xs -> Built xs
forall s (xs :: [s]).
SymMonoidal s =>
[Int] -> Built xs -> Built xs
permuteThen ((a -> Int) -> [a] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map a Int
positions Map a Int -> a -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) [a]
wanted)

-- | Each node has one producer and any number of consumers. Copy when a wire branches and
-- discard it when unused. Boxes with unused outputs still run; copying and discarding need not
-- be natural. Directed cycles are rejected unless 'tracedWith' enables the target's trace.
-- With tracing, nodes without producers feed themselves and their consumers through copying.
copyDiscard :: (CopyDiscard s) => Wiring s
copyDiscard :: forall s. CopyDiscard s => Wiring s
copyDiscard =
  Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
forall s.
Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
Wiring
    Feedback s
forall s. Feedback s
acyclic
    Scheduling
Sequential
    Maybe (SomeSort s -> Int)
forall a. Maybe a
P.Nothing
    (\Align s
al Feedback s
fb Scheduling
mode SomeSort s -> Int
sizeFn -> Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (Int -> Bool)
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
SymMonoidal s =>
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (Int -> Bool)
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBackDirected Maybe (Step '[x] '[y])
Align s
al Feedback s
fb Scheduling
mode SomeSort s -> Int
sizeFn (Bool -> Int -> Bool
forall a b. a -> b -> a
P.const Bool
P.True) [Key] -> [Key] -> Built xs -> Built xs
forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs
forall {s} (xs :: [s]).
CopyDiscard s =>
[Key] -> [Key] -> Built xs -> Built xs
copyWires)

-- | Frobenius spiders with sizes from 'Sized', planned as in 'frobeniusWith'.
frobenius :: (Hypergraph s, Sized s) => Wiring s
frobenius :: forall s. (Hypergraph s, Sized s) => Wiring s
frobenius = (SomeSort s -> Int) -> Wiring s
forall s. Hypergraph s => (SomeSort s -> Int) -> Wiring s
frobeniusWith SomeSort s -> Int
forall s. Sized s => SomeSort s -> Int
sizeFromSized

-- | Frobenius spiders with the given wire sizes. State boxes are contracted as a tree, using
-- the cheaper of numpy's greedy order and min-fill elimination. Remaining boxes follow a path;
-- nodes are merged and discarded as soon as their other uses allow. This preserves the
-- contraction planner used by 'Proarrow.Tools.Einsum.einsum'. Feedback uses the trace from
-- Frobenius cups and caps. The given sizes also weight swap reduction, including wire routing
-- within state contractions; routing preserves the contraction tree and its eliminated indices.
frobeniusWith :: (Hypergraph s) => (SomeSort s -> P.Int) -> Wiring s
frobeniusWith :: forall s. Hypergraph s => (SomeSort s -> Int) -> Wiring s
frobeniusWith SomeSort s -> Int
sizeFn = Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
forall s.
Feedback s
-> Scheduling
-> Maybe (SomeSort s -> Int)
-> (forall l (a :: OPENHG s l) (b :: OPENHG s l).
    Align s
    -> Feedback s
    -> Scheduling
    -> (SomeSort s -> Int)
    -> (l -> SomeArrow s)
    -> (a ~> b)
    -> Either String (WireSorts a ~> WireSorts b))
-> Wiring s
Wiring Feedback s
forall s. Hypergraph s => Feedback s
hypergraphTrace Scheduling
Sequential ((SomeSort s -> Int) -> Maybe (SomeSort s -> Int)
forall a. a -> Maybe a
P.Just SomeSort s -> Int
sizeFn) Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
forall l (a :: OPENHG s l) (b :: OPENHG s l).
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBackFrobenius

-- | Use the target's trace for feedback, replacing the wiring's default feedback policy.
-- For example, @tracedWith copyDiscard@ supports copying, discarding and directed cycles.
tracedWith :: (TracedMonoidal s) => Wiring s -> Wiring s
tracedWith :: forall s. TracedMonoidal s => Wiring s -> Wiring s
tracedWith Wiring s
wiring = Wiring s
wiring{wiringFeedback = traced}

-- | Place independent boxes side by side with tensor, routing wires between layers. Swap reduction
-- uses the wiring's existing sizes, or 'Sized' when no sizes were supplied. Each crossing is weighted
-- by the product of the wire sizes. Wiring operations and feedback are unchanged.
-- Without this modifier boxes are placed one at a time, with uniform swap costs unless the wiring
-- supplies sizes, as 'frobenius' and 'frobeniusWith' do.
layered :: (Sized s) => Wiring s -> Wiring s
layered :: forall s. Sized s => Wiring s -> Wiring s
layered Wiring s
wiring =
  Wiring s
wiring{wiringScheduling = Layered, wiringSize = P.Just (fromMaybe sizeFromSized (wiringSize wiring))}

data Scheduling = Sequential | Layered

-- | How to close feedback wires, independently of the wiring operations.
type Feedback :: Kind -> Type
data Feedback s = Feedback
  { forall s. Feedback s -> Bool
allowsCycles :: P.Bool
  , forall s.
Feedback s
-> forall (us :: [s]) (xs :: [s]) (ys :: [s]).
   Sorts us
   -> Sorts xs
   -> Sorts ys
   -> ((us ++ xs) ~> (us ++ ys))
   -> Either String (xs ~> ys)
closeFeedback
      :: forall us xs ys
       . Sorts (us :: [s])
      -> Sorts xs
      -> Sorts ys
      -> (us ++ xs) ~> (us ++ ys)
      -> P.Either P.String (xs ~> ys)
  }

-- | Reject directed feedback. No trace constraint is required.
acyclic :: forall s. Feedback s
acyclic :: forall s. Feedback s
acyclic = Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
forall s.
Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
Feedback Bool
P.False Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> Either String (xs ~> ys)
forall (us :: [s]) (xs :: [s]) (ys :: [s]).
Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> Either String (xs ~> ys)
close
  where
    close
      :: forall us xs ys
       . Sorts (us :: [s])
      -> Sorts xs
      -> Sorts ys
      -> (us ++ xs) ~> (us ++ ys)
      -> P.Either P.String (xs ~> ys)
    close :: forall (us :: [s]) (xs :: [s]) (ys :: [s]).
Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> Either String (xs ~> ys)
close ListOf SortOb us
Nil Sorts xs
_ Sorts ys
_ (us ++ xs) ~> (us ++ ys)
f = Strictified xs ys -> Either String (Strictified xs ys)
forall a b. b -> Either a b
P.Right (us ++ xs) ~> (us ++ ys)
Strictified xs ys
f
    close ListOf SortOb us
_ Sorts xs
_ Sorts ys
_ (us ++ xs) ~> (us ++ ys)
_ = String -> Either String (Strictified xs ys)
forall a b. a -> Either a b
P.Left String
"readBack: feedback requires a trace"

-- | Close feedback with the target's trace. Requires no copying or merging.
traced :: forall s. (TracedMonoidal s) => Feedback s
traced :: forall s. TracedMonoidal s => Feedback s
traced = Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
forall s.
Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
Feedback Bool
P.True (\Sorts us
us Sorts xs
xs Sorts ys
ys (us ++ xs) ~> (us ++ ys)
f -> Strictified xs ys -> Either String (Strictified xs ys)
forall a b. b -> Either a b
P.Right ((forall (u :: s) (x :: s) (y :: s).
 (Ob u, Ob x, Ob y) =>
 ((u ** x) ~> (u ** y)) -> x ~> y)
-> Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> xs ~> ys
forall {s} (us :: [s]) (xs :: [s]) (ys :: [s]).
SymMonoidal s =>
(forall (u :: s) (x :: s) (y :: s).
 (Ob u, Ob x, Ob y) =>
 ((u ** x) ~> (u ** y)) -> x ~> y)
-> Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> xs ~> ys
traceSorts (\ @u @x @y -> forall {m} {k} (t :: (m, k) +-> k) (p :: k +-> k) (a :: m) (x :: k)
       (y :: k).
(Costrong t p, Ob a, Ob x, Ob y) =>
p (Act t a x) (Act t a y) -> p x y
forall (t :: (s, s) +-> s) (p :: s +-> s) (a :: s) (x :: s)
       (y :: s).
(Costrong t p, Ob a, Ob x, Ob y) =>
p (Act t a x) (Act t a y) -> p x y
coact @Tensor @(Hom s) @u @x @y) Sorts us
us Sorts xs
xs Sorts ys
ys (us ++ xs) ~> (us ++ ys)
f))

-- | Close feedback with the trace derived from Frobenius cups and caps ('traceHG'). This keeps
-- the cup-and-cap form of hypergraph diagrams and needs no separate 'TracedMonoidal' instance.
hypergraphTrace :: (Hypergraph s) => Feedback s
hypergraphTrace :: forall s. Hypergraph s => Feedback s
hypergraphTrace = Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
forall s.
Bool
-> (forall (us :: [s]) (xs :: [s]) (ys :: [s]).
    Sorts us
    -> Sorts xs
    -> Sorts ys
    -> ((us ++ xs) ~> (us ++ ys))
    -> Either String (xs ~> ys))
-> Feedback s
Feedback Bool
P.True (\Sorts us
us Sorts xs
xs Sorts ys
ys (us ++ xs) ~> (us ++ ys)
f -> Strictified xs ys -> Either String (Strictified xs ys)
forall a b. b -> Either a b
P.Right ((forall (u :: s) (x :: s) (y :: s).
 (Ob u, Ob x, Ob y) =>
 ((u ** x) ~> (u ** y)) -> x ~> y)
-> Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> xs ~> ys
forall {s} (us :: [s]) (xs :: [s]) (ys :: [s]).
SymMonoidal s =>
(forall (u :: s) (x :: s) (y :: s).
 (Ob u, Ob x, Ob y) =>
 ((u ** x) ~> (u ** y)) -> x ~> y)
-> Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> xs ~> ys
traceSorts (\ @u @x @y -> forall (u :: s) (x :: s) (y :: s).
(Hypergraph s, Ob x, Ob y, Ob u) =>
((u ** x) ~> (u ** y)) -> x ~> y
forall {k} (u :: k) (x :: k) (y :: k).
(Hypergraph k, Ob x, Ob y, Ob u) =>
((u ** x) ~> (u ** y)) -> x ~> y
traceHG @u @x @y) Sorts us
us Sorts xs
xs Sorts ys
ys (us ++ xs) ~> (us ++ ys)
f))

-- | Interpret a graph using the given wiring, for example @readBack copyDiscard interpret graph@
-- or @readBack (tracedWith permutations) interpret graph@.
-- Sorts supplied from outside are compared by 'DecidableIso'; boxes are transported along the
-- resulting isomorphisms. Unsupported incidences or feedback return an error.
readBack
  :: forall {s} l a b
   . (DecidableIso s)
  => Wiring s
  -> (l -> SomeArrow s)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (WireSorts a ~> WireSorts b)
readBack :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
DecidableIso s =>
Wiring s
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBack Wiring s
wiring =
  Wiring s
-> forall l (a :: OPENHG s l) (b :: OPENHG s l).
   Align s
   -> Feedback s
   -> Scheduling
   -> (SomeSort s -> Int)
   -> (l -> SomeArrow s)
   -> (a ~> b)
   -> Either String (WireSorts a ~> WireSorts b)
forall s.
Wiring s
-> forall l (a :: OPENHG s l) (b :: OPENHG s l).
   Align s
   -> Feedback s
   -> Scheduling
   -> (SomeSort s -> Int)
   -> (l -> SomeArrow s)
   -> (a ~> b)
   -> Either String (WireSorts a ~> WireSorts b)
runWiring
    Wiring s
wiring
    (forall s. DecidableIso s => Align s
byIso @s)
    (Wiring s -> Feedback s
forall s. Wiring s -> Feedback s
wiringFeedback Wiring s
wiring)
    (Wiring s -> Scheduling
forall s. Wiring s -> Scheduling
wiringScheduling Wiring s
wiring)
    ((SomeSort s -> Int)
-> Maybe (SomeSort s -> Int) -> SomeSort s -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int -> SomeSort s -> Int
forall a b. a -> b -> a
P.const Int
1) (Wiring s -> Maybe (SomeSort s -> Int)
forall s. Wiring s -> Maybe (SomeSort s -> Int)
wiringSize Wiring s
wiring))

-- | The read-back, with the sorts lined up by the given alignment.
readBackFrobenius
  :: forall {s} l a b
   . (SymMonoidal s, Supplies Frobenius s)
  => Align s
  -> Feedback s
  -> Scheduling
  -> (SomeSort s -> P.Int)
  -> (l -> SomeArrow s)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (WireSorts a ~> WireSorts b)
readBackFrobenius :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBackFrobenius Align s
al Feedback s
fbChoice Scheduling
mode SomeSort s -> Int
sizeFn l -> SomeArrow s
interp a ~> b
hg =
  a ~> b
DecCospan a b
hg DecCospan a b
-> ((Ob a, Ob b) =>
    Either
      String
      (Strictified
         (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))))
-> Either
     String
     (Strictified
        (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
forall {k1} {k2} (p :: k1 +-> k2) (a :: k2) (b :: k1) r.
Profunctor p =>
p a b -> ((Ob a, Ob b) => r) -> r
// do
    arrows0 <-
      Align s
-> (Int -> SomeSort s)
-> (l -> SomeArrow s)
-> String
-> [(Int, Box l Int)]
-> Either String (Map Int (SomeArrow s))
forall {s} l.
Align s
-> (Int -> SomeSort s)
-> (l -> SomeArrow s)
-> String
-> [(Int, Box l Int)]
-> Either String (Map Int (SomeArrow s))
interpretBoxes
        Maybe (Step '[x] '[y])
Align s
al
        (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!)
        l -> SomeArrow s
interp
        String
"readBack: the arrow of a label does not have the sorts of its box"
        [(Int, Box l Int)]
labelled
    let arrows =
          Map Int (SomeArrow s)
-> Map Int (SomeArrow s) -> Map Int (SomeArrow s)
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union
            Map Int (SomeArrow s)
arrows0
            ([(Int, SomeArrow s)] -> Map Int (SomeArrow s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
j, Align s
-> (Key -> SomeSort s)
-> Map Int (SomeArrow s)
-> Tree
-> SomeArrow s
forall s.
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> Map Int (SomeArrow s)
-> Tree
-> SomeArrow s
pieceArrow Maybe (Step '[x] '[y])
Align s
al Key -> SomeSort s
nodeSort Map Int (SomeArrow s)
arrows0 ((Key -> Integer) -> Tree -> Tree
routeTree (Int -> Integer
forall a. Integral a => a -> Integer
P.toInteger (Int -> Integer) -> (Key -> Int) -> Key -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. SomeSort s -> Int
sizeFn (SomeSort s -> Int) -> (Key -> SomeSort s) -> Key -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. Key -> SomeSort s
nodeSort) Tree
t)) | (Int
j, Tree
t) <- [(Int, Tree)]
merged])
    withListOf (P.fmap (nodeSort P.. KN) (feedback lt)) \ListOf SortOb xs
fb ->
      let insS :: Sorts (PortSorts (UN SUB (UN DC a)))
insS = forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(WireSorts a)
          outsS :: Sorts (PortSorts (UN SUB (UN DC b)))
outsS = forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(WireSorts b)
          start :: ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start = ListOf SortOb xs
-> ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {k} (c :: OB k) (as :: [k]) (bs :: [k]).
ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)
appendListOf ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC a)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
insS
          initial :: [Key]
initial = (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN (Lifetimes -> [Int]
feedback Lifetimes
lt [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Shape -> [Int]
shapeIns Shape
shape)
          wanted :: [Key]
wanted = (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KL (Lifetimes -> [Int]
feedback Lifetimes
lt) [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Lifetimes -> Int -> Key
outKey Lifetimes
lt) (Shape -> [Int]
shapeOuts Shape
shape)
          plan :: [Key] -> (Int, [(Int, Box () Int)]) -> ([Key], [LayerEntry])
plan [Key]
bundle0 (Int
t, [(Int, Box () Int)]
layer) =
            let entries :: [LayerEntry]
entries = [(Int -> Key) -> (Int, Box () Int) -> LayerEntry
forall l. (Int -> Key) -> (Int, Box l Int) -> LayerEntry
gateEntry (Lifetimes -> Int -> Key
outKey Lifetimes
lt) (Int, Box () Int)
bx | (Int, Box () Int)
bx <- [(Int, Box () Int)]
layer]
                need :: [Key]
need = (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryInputs [LayerEntry]
entries
                made :: [Key]
made = (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
entries
                carry :: [Key]
carry = [Key
k | Key
k <- [Key] -> [Key]
forall a. Ord a => [a] -> [a]
nubOrd ([Key]
bundle0 [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
need), Lifetimes -> Int -> Key -> Bool
live Lifetimes
lt Int
t Key
k Bool -> Bool -> Bool
P.|| Key
k Key -> [Key] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` [Key]
made]
                whole :: [LayerEntry]
whole = (Key -> LayerEntry) -> [Key] -> [LayerEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Key -> LayerEntry
identityEntry [Key]
carry [LayerEntry] -> [LayerEntry] -> [LayerEntry]
forall a. [a] -> [a] -> [a]
P.++ [LayerEntry]
entries
            in ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
whole, [LayerEntry]
whole)
          planned :: [[LayerEntry]]
planned = ([Key], [[LayerEntry]]) -> [[LayerEntry]]
forall a b. (a, b) -> b
P.snd (([Key] -> (Int, [(Int, Box () Int)]) -> ([Key], [LayerEntry]))
-> [Key] -> [(Int, [(Int, Box () Int)])] -> ([Key], [[LayerEntry]])
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [Key] -> (Int, [(Int, Box () Int)]) -> ([Key], [LayerEntry])
plan [Key]
initial ([Int] -> [[(Int, Box () Int)]] -> [(Int, [(Int, Box () Int)])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
1 ..] [[(Int, Box () Int)]]
layers))
          ordered :: [[LayerEntry]]
ordered = (Key -> Integer)
-> [Key] -> [Key] -> [[LayerEntry]] -> [[LayerEntry]]
orderLayers (Int -> Integer
forall a. Integral a => a -> Integer
P.toInteger (Int -> Integer) -> (Key -> Int) -> Key -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. SomeSort s -> Int
sizeFn (SomeSort s -> Int) -> (Key -> SomeSort s) -> Key -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. Key -> SomeSort s
nodeSort) [Key]
initial [Key]
wanted [[LayerEntry]]
planned
          ([Key]
bundle, Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
body) = Align s
-> (forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws)
-> Map Int (SomeArrow s)
-> [Key]
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> [[LayerEntry]]
-> ([Key], Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))))
forall s (xs :: [s]).
SymMonoidal s =>
Align s
-> (forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws)
-> Map Int (SomeArrow s)
-> [Key]
-> Built xs
-> [[LayerEntry]]
-> ([Key], Built xs)
buildLayers Maybe (Step '[x] '[y])
Align s
al (Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built ws
-> Built ws
forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built xs
-> Built xs
transition Maybe (Step '[x] '[y])
Align s
al Key -> SomeSort s
nodeSort []) Map Int (SomeArrow s)
arrows [Key]
initial (ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Step
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start Step
  (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
  (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {s} (xs :: [s]). Step xs xs
Same) [[LayerEntry]]
ordered
          final :: Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
final =
            Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built xs
-> Built xs
transition
              Maybe (Step '[x] '[y])
Align s
al
              Key -> SomeSort s
nodeSort
              (Shape -> [(Int, Box () Int)] -> [Key]
isolated Shape
shape [(Int, Box () Int)]
boxes0)
              [Key]
bundle
              [Key]
wanted
              Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
body
      in case Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
final of
           Built Sorts ys
ys Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
whole -> case Align s
-> Sorts ys
-> Sorts (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Maybe
     (Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b))))))
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Align s -> Sorts xs -> Sorts ys -> Maybe (Step xs ys)
alignSteps Maybe (Step '[x] '[y])
Align s
al Sorts ys
ys (ListOf SortOb xs
-> ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Sorts (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall {k} (c :: OB k) (as :: [k]) (bs :: [k]).
ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)
appendListOf ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC b)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
outsS) of
             P.Just Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
to -> Feedback s
-> forall (us :: [s]) (xs :: [s]) (ys :: [s]).
   Sorts us
   -> Sorts xs
   -> Sorts ys
   -> ((us ++ xs) ~> (us ++ ys))
   -> Either String (xs ~> ys)
forall s.
Feedback s
-> forall (us :: [s]) (xs :: [s]) (ys :: [s]).
   Sorts us
   -> Sorts xs
   -> Sorts ys
   -> ((us ++ xs) ~> (us ++ ys))
   -> Either String (xs ~> ys)
closeFeedback Feedback s
fbChoice ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC a)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
insS Sorts (PortSorts (UN SUB (UN DC b)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
outsS (Sorts ys
-> Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> ys ~> (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts ys
ys Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
to Strictified ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Strictified (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
-> Strictified
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
-> (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
whole)
             Maybe (Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b))))))
P.Nothing -> String
-> Either
     String
     (Strictified
        (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
        (PortSorts (FH (UN FH (UN SUB (UN DC b))))))
forall a. HasCallStack => String -> a
P.error String
"readBack: the boundaries were planned with other sorts"
  where
    (Shape
shape, Map Int (SomeSort s)
sortAt, [(Int, Box l Int)]
labelled) = (a ~> b) -> (Shape, Map Int (SomeSort s), [(Int, Box l Int)])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> (Shape, Map Int (SomeSort s), [(Int, Box l Int)])
prepareReadBack a ~> b
hg
    nodeSort :: Key -> SomeSort s
nodeSort Key
k = Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.! Key -> Int
keyNode Key
k
    boxes0 :: [(Int, Box () Int)]
boxes0 = [(Int
i, Box l Int
bx{label = ()}) | (Int
i, Box l Int
bx) <- [(Int, Box l Int)]
labelled]
    size :: Set Int -> Double
size Set Int
ns = [Double] -> Double
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
P.product [Int -> Double
forall a b. (Integral a, Num b) => a -> b
P.fromIntegral (SomeSort s -> Int
sizeFn (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.! Int
n)) :: P.Double | Int
n <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
ns]
    ([(Int, Box () Int)]
boxesIx, [(Int, Tree)]
merged) = [(Int, Box () Int)]
-> [Piece] -> ([(Int, Box () Int)], [(Int, Tree)])
pathBoxes [(Int, Box () Int)]
boxes0 ((Set Int -> Double) -> Shape -> [(Int, Box () Int)] -> [Piece]
contractStates Set Int -> Double
size Shape
shape [(Int, Box () Int)]
boxes0)
    order :: [(Int, Box () Int)]
order = (Set Int -> Double)
-> Shape -> [(Int, Box () Int)] -> [(Int, Box () Int)]
schedule Set Int -> Double
size Shape
shape [(Int, Box () Int)]
boxesIx
    layers :: [[(Int, Box () Int)]]
layers = Scheduling -> [Int] -> [(Int, Box () Int)] -> [[(Int, Box () Int)]]
forall l.
Scheduling -> [Int] -> [(Int, Box l Int)] -> [[(Int, Box l Int)]]
boxLayers Scheduling
mode (Lifetimes -> [Int]
feedback (Shape -> [(Int, Box () Int)] -> [[(Int, Box () Int)]] -> Lifetimes
lifetimes Shape
shape [(Int, Box () Int)]
boxesIx (((Int, Box () Int) -> [(Int, Box () Int)])
-> [(Int, Box () Int)] -> [[(Int, Box () Int)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
forall a. a -> [a] -> [a]
: []) [(Int, Box () Int)]
order))) [(Int, Box () Int)]
order
    lt :: Lifetimes
lt = Shape -> [(Int, Box () Int)] -> [[(Int, Box () Int)]] -> Lifetimes
lifetimes Shape
shape [(Int, Box () Int)]
boxesIx [[(Int, Box () Int)]]
layers

-- Directed readers keep one wire per available node between boxes. Routing supplies the
-- current inputs and retains only those nodes needed by later boxes or the output boundary.
readBackDirected
  :: forall {s} l a b
   . (SymMonoidal s)
  => Align s
  -> Feedback s
  -> Scheduling
  -> (SomeSort s -> P.Int)
  -> (P.Int -> P.Bool)
  -> (forall xs. [Key] -> [Key] -> Built (xs :: [s]) -> Built xs)
  -> (l -> SomeArrow s)
  -> (a :: OPENHG s l) ~> b
  -> P.Either P.String (WireSorts a ~> WireSorts b)
readBackDirected :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
SymMonoidal s =>
Align s
-> Feedback s
-> Scheduling
-> (SomeSort s -> Int)
-> (Int -> Bool)
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> (l -> SomeArrow s)
-> (a ~> b)
-> Either String (WireSorts a ~> WireSorts b)
readBackDirected Align s
al Feedback s
fbChoice Scheduling
mode SomeSort s -> Int
sizeFn Int -> Bool
acceptsConsumers forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs
route l -> SomeArrow s
interp a ~> b
hg =
  a ~> b
DecCospan a b
hg DecCospan a b
-> ((Ob a, Ob b) =>
    Either
      String
      (Strictified
         (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))))
-> Either
     String
     (Strictified
        (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
forall {k1} {k2} (p :: k1 +-> k2) (a :: k2) (b :: k1) r.
Profunctor p =>
p a b -> ((Ob a, Ob b) => r) -> r
// do
    let (shape :: Shape
shape@(Shape [Int]
_ [Int]
ins [Int]
outs), Map Int (SomeSort s)
sortAt, [(Int, Box l Int)]
numbered) = (DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC a))))))))
 ~> DC
      (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC b)))))))))
-> (Shape, Map Int (SomeSort s), [(Int, Box l Int)])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> (Shape, Map Int (SomeSort s), [(Int, Box l Int)])
prepareReadBack a ~> b
DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC a))))))))
~> DC (SUB (FH (Port (PortSorts (FH (UN FH (UN SUB (UN DC b))))))))
hg
    (order, fbNodes) <- Bool
-> (Int -> Bool)
-> Shape
-> [(Int, Box l Int)]
-> Either String ([(Int, Box l Int)], [Int])
forall l.
Bool
-> (Int -> Bool)
-> Shape
-> [(Int, Box l Int)]
-> Either String ([(Int, Box l Int)], [Int])
directedOrder (Feedback s -> Bool
forall s. Feedback s -> Bool
allowsCycles Feedback s
fbChoice) Int -> Bool
acceptsConsumers Shape
shape [(Int, Box l Int)]
numbered
    arrows <- interpretBoxes al (sortAt M.!) interp "readBack: an arrow does not fit its box" numbered
    withListOf (P.fmap (sortAt M.!) fbNodes) \ListOf SortOb xs
fb -> do
      let insS :: Sorts (PortSorts (UN SUB (UN DC a)))
insS = forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(WireSorts a)
          outsS :: Sorts (PortSorts (UN SUB (UN DC b)))
outsS = forall s (xs :: [s]). SortList xs => Sorts xs
sorts @s @(WireSorts b)
          start :: ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start = ListOf SortOb xs
-> ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {k} (c :: OB k) (as :: [k]) (bs :: [k]).
ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)
appendListOf ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC a)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
insS
          produced :: Set Int
produced = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (((Int, Box l Int) -> [Int]) -> [(Int, Box l Int)] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap (Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs (Box l Int -> [Int])
-> ((Int, Box l Int) -> Box l Int) -> (Int, Box l Int) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Int, Box l Int) -> Box l Int
forall a b. (a, b) -> b
P.snd) [(Int, Box l Int)]
numbered)
          feedbackOutputs :: Set Int
feedbackOutputs = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
fbNodes) Set Int
produced
          made :: Int -> Key
made Int
n = if Int
n Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
feedbackOutputs then Int -> Key
KL Int
n else Int -> Key
KN Int
n
          wanted :: [Key]
wanted = (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
made [Int]
fbNodes [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN [Int]
outs
          layers :: [[(Int, Box l Int)]]
layers = Scheduling -> [Int] -> [(Int, Box l Int)] -> [[(Int, Box l Int)]]
forall l.
Scheduling -> [Int] -> [(Int, Box l Int)] -> [[(Int, Box l Int)]]
boxLayers Scheduling
mode [Int]
fbNodes [(Int, Box l Int)]
order
          uses :: [(Int, [(Int, Box l Int)])]
uses = [Int] -> [[(Int, Box l Int)]] -> [(Int, [(Int, Box l Int)])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 :: P.Int ..] [[(Int, Box l Int)]]
layers
          lastUse :: Map Key Int
lastUse =
            (Int -> Int -> Int) -> [(Key, Int)] -> Map Key Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
              Int -> Int -> Int
forall a. Ord a => a -> a -> a
P.max
              ([(Key
n, [[(Int, Box l Int)]] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [[(Int, Box l Int)]]
layers) | Key
n <- [Key]
wanted] [(Key, Int)] -> [(Key, Int)] -> [(Key, Int)]
forall a. [a] -> [a] -> [a]
P.++ [(Int -> Key
KN Int
n, Int
j) | (Int
j, [(Int, Box l Int)]
layer) <- [(Int, [(Int, Box l Int)])]
uses, (Int
_, Box l Int
bx) <- [(Int, Box l Int)]
layer, Int
n <- Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
bx])
          plan :: [Key] -> (Int, [(Int, Box l Int)]) -> ([Key], [LayerEntry])
plan [Key]
bundle0 (Int
j, [(Int, Box l Int)]
layer) =
            let carry :: [Key]
carry = (Key -> Bool) -> [Key] -> [Key]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (\Key
n -> Int -> Key -> Map Key Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (-Int
1) Key
n Map Key Int
lastUse Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.> Int
j) [Key]
bundle0
                entries :: [LayerEntry]
entries = (Key -> LayerEntry) -> [Key] -> [LayerEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Key -> LayerEntry
identityEntry [Key]
carry [LayerEntry] -> [LayerEntry] -> [LayerEntry]
forall a. [a] -> [a] -> [a]
P.++ ((Int, Box l Int) -> LayerEntry)
-> [(Int, Box l Int)] -> [LayerEntry]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Int -> Key) -> (Int, Box l Int) -> LayerEntry
forall l. (Int -> Key) -> (Int, Box l Int) -> LayerEntry
gateEntry Int -> Key
made) [(Int, Box l Int)]
layer
            in ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
entries, [LayerEntry]
entries)
          initial :: [Key]
initial = (Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN ([Int]
fbNodes [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [Int]
ins)
          planned :: [[LayerEntry]]
planned = ([Key], [[LayerEntry]]) -> [[LayerEntry]]
forall a b. (a, b) -> b
P.snd (([Key] -> (Int, [(Int, Box l Int)]) -> ([Key], [LayerEntry]))
-> [Key] -> [(Int, [(Int, Box l Int)])] -> ([Key], [[LayerEntry]])
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [Key] -> (Int, [(Int, Box l Int)]) -> ([Key], [LayerEntry])
plan [Key]
initial [(Int, [(Int, Box l Int)])]
uses)
          ordered :: [[LayerEntry]]
ordered = (Key -> Integer)
-> [Key] -> [Key] -> [[LayerEntry]] -> [[LayerEntry]]
orderLayers (Int -> Integer
forall a. Integral a => a -> Integer
P.toInteger (Int -> Integer) -> (Key -> Int) -> Key -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. SomeSort s -> Int
sizeFn (SomeSort s -> Int) -> (Key -> SomeSort s) -> Key -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Map Int (SomeSort s)
sortAt Map Int (SomeSort s) -> Int -> SomeSort s
forall k a. Ord k => Map k a -> k -> a
M.!) (Int -> SomeSort s) -> (Key -> Int) -> Key -> SomeSort s
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. Key -> Int
keyNode) [Key]
initial [Key]
wanted [[LayerEntry]]
planned
          ([Key]
bundle, Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
body) = Align s
-> (forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs)
-> Map Int (SomeArrow s)
-> [Key]
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> [[LayerEntry]]
-> ([Key], Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))))
forall s (xs :: [s]).
SymMonoidal s =>
Align s
-> (forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws)
-> Map Int (SomeArrow s)
-> [Key]
-> Built xs
-> [[LayerEntry]]
-> ([Key], Built xs)
buildLayers Maybe (Step '[x] '[y])
Align s
al [Key] -> [Key] -> Built ws -> Built ws
forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs
route Map Int (SomeArrow s)
arrows [Key]
initial (ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Step
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start Step
  (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
  (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall {s} (xs :: [s]). Step xs xs
Same) [[LayerEntry]]
ordered
      case [Key]
-> [Key]
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
forall (xs :: [s]). [Key] -> [Key] -> Built xs -> Built xs
route [Key]
bundle [Key]
wanted Built (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
body of
        Built Sorts ys
ys Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
whole -> case Align s
-> Sorts ys
-> Sorts (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Maybe
     (Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b))))))
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Align s -> Sorts xs -> Sorts ys -> Maybe (Step xs ys)
alignSteps Maybe (Step '[x] '[y])
Align s
al Sorts ys
ys (ListOf SortOb xs
-> ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Sorts (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall {k} (c :: OB k) (as :: [k]) (bs :: [k]).
ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)
appendListOf ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC b)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
outsS) of
          P.Just Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
into -> Feedback s
-> forall (us :: [s]) (xs :: [s]) (ys :: [s]).
   Sorts us
   -> Sorts xs
   -> Sorts ys
   -> ((us ++ xs) ~> (us ++ ys))
   -> Either String (xs ~> ys)
forall s.
Feedback s
-> forall (us :: [s]) (xs :: [s]) (ys :: [s]).
   Sorts us
   -> Sorts xs
   -> Sorts ys
   -> ((us ++ xs) ~> (us ++ ys))
   -> Either String (xs ~> ys)
closeFeedback Feedback s
fbChoice ListOf SortOb xs
fb Sorts (PortSorts (UN SUB (UN DC a)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
insS Sorts (PortSorts (UN SUB (UN DC b)))
ListOf SortOb (PortSorts (FH (UN FH (UN SUB (UN DC b)))))
outsS (Sorts ys
-> Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> ys ~> (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts ys
ys Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
into Strictified ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
-> Strictified (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
-> Strictified
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
     (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b)))))
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
-> Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
-> (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf ListOf SortOb (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a)))))
start Step (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC a))))) ys
whole)
          Maybe (Step ys (xs ++ PortSorts (FH (UN FH (UN SUB (UN DC b))))))
P.Nothing -> String
-> Either
     String
     (Strictified
        (PortSorts (FH (UN FH (UN SUB (UN DC a)))))
        (PortSorts (FH (UN FH (UN SUB (UN DC b))))))
forall a b. a -> Either a b
P.Left String
"readBack: the output boundary has other sorts"

-- Copy each available wire to its requested multiplicity, then permute the individual copies.
copyWires :: forall {s} xs. (CopyDiscard s) => [Key] -> [Key] -> Built (xs :: [s]) -> Built xs
copyWires :: forall {s} (xs :: [s]).
CopyDiscard s =>
[Key] -> [Key] -> Built xs -> Built xs
copyWires [Key]
bundle [Key]
wanted Built xs
body = [Int] -> Built xs -> Built xs
forall s (xs :: [s]).
SymMonoidal s =>
[Int] -> Built xs -> Built xs
permuteThen [Int]
permutation ([Key] -> Sorts ys -> Built ys
forall (ws :: [s]). [Key] -> Sorts ws -> Built ws
expand [Key]
bundle (forall {ys :: [s]}. Sorts ys -> Built ys) -> Built xs -> Built xs
forall {s} (xs :: [s]).
Monoidal s =>
(forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
`afterBuilt` Built xs
body)
  where
    counts :: Map Key Int
counts = (Int -> Int -> Int) -> [(Key, Int)] -> Map Key Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) [(Key
n, Int
1 :: P.Int) | Key
n <- [Key]
wanted]
    count :: Key -> Int
count Key
n = Int -> Key -> Map Key Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Key
n Map Key Int
counts
    expanded :: [Key]
expanded = (Key -> [Key]) -> [Key] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap (\Key
n -> Int -> Key -> [Key]
forall a. Int -> a -> [a]
P.replicate (Key -> Int
count Key
n) Key
n) [Key]
bundle
    numbered :: t a -> t (a, Int)
numbered t a
ns = (Map a Int, t (a, Int)) -> t (a, Int)
forall a b. (a, b) -> b
P.snd ((Map a Int -> a -> (Map a Int, (a, Int)))
-> Map a Int -> t a -> (Map a Int, t (a, Int))
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Map a Int -> a -> (Map a Int, (a, Int))
forall {a}. Ord a => Map a Int -> a -> (Map a Int, (a, Int))
number Map a Int
forall k a. Map k a
M.empty t a
ns)
    number :: Map a Int -> a -> (Map a Int, (a, Int))
number Map a Int
seen a
n =
      let i :: Int
i = Int -> a -> Map a Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault (Int
0 :: P.Int) a
n Map a Int
seen
      in (a -> Int -> Map a Int -> Map a Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
n (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
1) Map a Int
seen, (a
n, Int
i))
    positions :: Map (Key, Int) Int
positions = [((Key, Int), Int)] -> Map (Key, Int) Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Key, Int)] -> [Int] -> [((Key, Int), Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip ([Key] -> [(Key, Int)]
forall {t :: Type -> Type} {a}.
(Traversable t, Ord a) =>
t a -> t (a, Int)
numbered [Key]
expanded) [Int
0 ..])
    permutation :: [Int]
permutation = ((Key, Int) -> Int) -> [(Key, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Map (Key, Int) Int
positions Map (Key, Int) Int -> (Key, Int) -> Int
forall k a. Ord k => Map k a -> k -> a
M.!) ([Key] -> [(Key, Int)]
forall {t :: Type -> Type} {a}.
(Traversable t, Ord a) =>
t a -> t (a, Int)
numbered [Key]
wanted)
    expand :: [Key] -> Sorts (ws :: [s]) -> Built ws
    expand :: forall (ws :: [s]). [Key] -> Sorts ws -> Built ws
expand [] ListOf SortOb ws
Nil = Sorts '[] -> Step ws '[] -> Built ws
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Step ws ws
Step ws '[]
forall {s} (xs :: [s]). Step xs xs
Same
    expand (Key
n : [Key]
ns) (Cons @x ListOf SortOb xs1
xs) = Sorts '[x]
-> Built '[x]
-> ListOf SortOb xs1
-> Built xs1
-> Built ('[x] ++ xs1)
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @x) (forall (x :: s). CocommutativeComonoid x => Int -> Built '[x]
forall {s} (x :: s). CocommutativeComonoid x => Int -> Built '[x]
copies @x (Key -> Int
count Key
n)) ListOf SortOb xs1
xs ([Key] -> ListOf SortOb xs1 -> Built xs1
forall (ws :: [s]). [Key] -> Sorts ws -> Built ws
expand [Key]
ns ListOf SortOb xs1
xs)
    expand [Key]
_ ListOf SortOb ws
_ = String -> Built ws
forall a. HasCallStack => String -> a
P.error String
"readBack: the bundle has other sorts"

-- The same node numbering is used by the planners and by box interpretation.
prepareReadBack
  :: forall {s} l a b
   . (a :: OPENHG s l) ~> b
  -> (Shape, M.Map P.Int (SomeSort s), [(P.Int, Box l P.Int)])
prepareReadBack :: forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> (Shape, Map Int (SomeSort s), [(Int, Box l Int)])
prepareReadBack a ~> b
hg =
  let ([SomeSort s]
nodes, [Int]
ins, [Int]
outs, [Box l Int]
boxes) = (a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
forall {s} l (a :: OPENHG s l) (b :: OPENHG s l).
(a ~> b) -> ([SomeSort s], [Int], [Int], [Box l Int])
hypergraphParts a ~> b
hg
  in ([Int] -> [Int] -> [Int] -> Shape
Shape [Int
0 .. [SomeSort s] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [SomeSort s]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1] [Int]
ins [Int]
outs, [(Int, SomeSort s)] -> Map Int (SomeSort s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [SomeSort s] -> [(Int, SomeSort s)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [SomeSort s]
nodes), [Int] -> [Box l Int] -> [(Int, Box l Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [Box l Int]
boxes)

interpretBoxes
  :: forall {s} l
   . Align s
  -> (P.Int -> SomeSort s)
  -> (l -> SomeArrow s)
  -> P.String
  -> [(P.Int, Box l P.Int)]
  -> P.Either P.String (M.Map P.Int (SomeArrow s))
interpretBoxes :: forall {s} l.
Align s
-> (Int -> SomeSort s)
-> (l -> SomeArrow s)
-> String
-> [(Int, Box l Int)]
-> Either String (Map Int (SomeArrow s))
interpretBoxes Align s
al Int -> SomeSort s
nodeSort l -> SomeArrow s
interp String
message = ([(Int, SomeArrow s)] -> Map Int (SomeArrow s))
-> Either String [(Int, SomeArrow s)]
-> Either String (Map Int (SomeArrow s))
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap [(Int, SomeArrow s)] -> Map Int (SomeArrow s)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (Either String [(Int, SomeArrow s)]
 -> Either String (Map Int (SomeArrow s)))
-> ([(Int, Box l Int)] -> Either String [(Int, SomeArrow s)])
-> [(Int, Box l Int)]
-> Either String (Map Int (SomeArrow s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. ((Int, Box l Int) -> Either String (Int, SomeArrow s))
-> [(Int, Box l Int)] -> Either String [(Int, SomeArrow s)]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
P.traverse (Int, Box l Int) -> Either String (Int, SomeArrow s)
checkBox
  where
    checkBox :: (Int, Box l Int) -> Either String (Int, SomeArrow s)
checkBox (Int
i, Box l
x [Int]
is [Int]
os) = case l -> SomeArrow s
interp l
x of
      arrow :: SomeArrow s
arrow@(SomeArrow Sorts as
xs Sorts bs
ys as ~> bs
_)
        | Align s -> [SomeSort s] -> [SomeSort s] -> Bool
forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Maybe (Step '[x] '[y])
Align s
al (Sorts as -> [SomeSort s]
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> [SomeOf c]
someOfList Sorts as
xs) ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> SomeSort s
nodeSort [Int]
is)
            Bool -> Bool -> Bool
P.&& Align s -> [SomeSort s] -> [SomeSort s] -> Bool
forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Maybe (Step '[x] '[y])
Align s
al (Sorts bs -> [SomeSort s]
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> [SomeOf c]
someOfList Sorts bs
ys) ((Int -> SomeSort s) -> [Int] -> [SomeSort s]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> SomeSort s
nodeSort [Int]
os) ->
            (Int, SomeArrow s) -> Either String (Int, SomeArrow s)
forall a b. b -> Either a b
P.Right (Int
i, SomeArrow s
arrow)
        | Bool
P.otherwise -> String -> Either String (Int, SomeArrow s)
forall a b. a -> Either a b
P.Left String
message

-- Each node has at most one producer. With copying and tracing, a node without a producer
-- feeds itself and its consumers. Cut unavailable inputs of the first blocked box to schedule cycles.
directedOrder
  :: P.Bool
  -> (P.Int -> P.Bool)
  -> Shape
  -> [(P.Int, Box l P.Int)]
  -> P.Either P.String ([(P.Int, Box l P.Int)], [P.Int])
directedOrder :: forall l.
Bool
-> (Int -> Bool)
-> Shape
-> [(Int, Box l Int)]
-> Either String ([(Int, Box l Int)], [Int])
directedOrder Bool
canTrace Int -> Bool
acceptsConsumers Shape
sh [(Int, Box l Int)]
boxes
  | Bool -> Bool
P.not ((Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.all Int -> Bool
acceptsProducer (Shape -> [Int]
shapeNodes Shape
sh)) =
      String -> Either String ([(Int, Box l Int)], [Int])
forall a b. a -> Either a b
P.Left String
"readBack: every node must have one producer"
  | Bool -> Bool
P.not ((Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.all (\Int
n -> Int
n Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
loops Bool -> Bool -> Bool
P.|| Int -> Bool
acceptsConsumers (Int -> Int -> Map Int Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Int
n Map Int Int
consumerCounts)) (Shape -> [Int]
shapeNodes Shape
sh)) =
      String -> Either String ([(Int, Box l Int)], [Int])
forall a b. a -> Either a b
P.Left String
"readBack: unsupported number of consumers"
  | Bool -> Bool
P.not Bool
canTrace Bool -> Bool -> Bool
P.&& Bool -> Bool
P.not (Set Int -> Bool
forall a. Set a -> Bool
Set.null Set Int
loops) = String -> Either String ([(Int, Box l Int)], [Int])
forall a b. a -> Either a b
P.Left String
"readBack: isolated loops require a trace"
  | Bool
P.otherwise = Set Int
-> Set Int
-> Map Int Int
-> [(Int, Box l Int)]
-> [Int]
-> Either String ([(Int, Box l Int)], [Int])
go Set Int
available0 Set Int
ready Map Int Int
counts [] (Set Int -> [Int]
forall a. Set a -> [a]
Set.toDescList Set Int
sources)
  where
    producers :: Map Int Int
producers = (Int -> Int -> Int) -> [(Int, Int)] -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) [(Int
n, Int
1 :: P.Int) | Int
n <- Shape -> [Int]
shapeIns Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ ((Int, Box l Int) -> [Int]) -> [(Int, Box l Int)] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap (Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs (Box l Int -> [Int])
-> ((Int, Box l Int) -> Box l Int) -> (Int, Box l Int) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Int, Box l Int) -> Box l Int
forall a b. (a, b) -> b
P.snd) [(Int, Box l Int)]
boxes]
    consumerCounts :: Map Int Int
consumerCounts = (Int -> Int -> Int) -> [(Int, Int)] -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) [(Int
n, Int
1 :: P.Int) | Int
n <- Shape -> [Int]
shapeOuts Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ ((Int, Box l Int) -> [Int]) -> [(Int, Box l Int)] -> [Int]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap (Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs (Box l Int -> [Int])
-> ((Int, Box l Int) -> Box l Int) -> (Int, Box l Int) -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. (Int, Box l Int) -> Box l Int
forall a b. (a, b) -> b
P.snd) [(Int, Box l Int)]
boxes]
    sources :: Set Int
sources = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeNodes Shape
sh) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map Int Int -> Set Int
forall k a. Map k a -> Set k
M.keysSet Map Int Int
producers
    loops :: Set Int
loops = Set Int
sources Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Map Int Int -> Set Int
forall k a. Map k a -> Set k
M.keysSet Map Int Int
consumerCounts
    acceptsProducer :: Int -> Bool
acceptsProducer Int
n = case Int -> Int -> Map Int Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Int
n Map Int Int
producers of
      Int
1 -> Bool
P.True
      Int
0 -> Int
n Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
loops Bool -> Bool -> Bool
P.|| (Bool
canTrace Bool -> Bool -> Bool
P.&& Int -> Bool
acceptsConsumers (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int -> Int -> Map Int Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Int
n Map Int Int
consumerCounts))
      Int
_ -> Bool
P.False
    available0 :: Set Int
available0 = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
sources ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeIns Shape
sh))
    counts :: Map Int Int
counts = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
i, [Int] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length ((Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
available0) (Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
bx))) | (Int
i, Box l Int
bx) <- [(Int, Box l Int)]
boxes]
    ready :: Set Int
ready = Map Int Int -> Set Int
forall k a. Map k a -> Set k
M.keysSet ((Int -> Bool) -> Map Int Int -> Map Int Int
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
0) Map Int Int
counts)
    consumers :: Map Int [Int]
consumers = ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(P.++) [(Int
n, [Int
i]) | (Int
i, Box l Int
bx) <- [(Int, Box l Int)]
boxes, Int
n <- Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
bx]
    table :: Map Int (Box l Int)
table = [(Int, Box l Int)] -> Map Int (Box l Int)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int, Box l Int)]
boxes
    release :: (Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int)
release (Set Int, Map Int Int)
acc Int
n = ((Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int))
-> (Set Int, Map Int Int) -> [Int] -> (Set Int, Map Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int)
forall {a} {a}.
(Ord a, Num a, Eq a) =>
(Set a, Map a a) -> a -> (Set a, Map a a)
releaseBox (Set Int, Map Int Int)
acc ([Int] -> Int -> Map Int [Int] -> [Int]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] Int
n Map Int [Int]
consumers)
    releaseBox :: (Set a, Map a a) -> a -> (Set a, Map a a)
releaseBox acc :: (Set a, Map a a)
acc@(Set a
queue, Map a a
remaining) a
i = case a -> Map a a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
i Map a a
remaining of
      Maybe a
P.Nothing -> (Set a, Map a a)
acc
      P.Just a
count ->
        let count' :: a
count' = a
count a -> a -> a
forall a. Num a => a -> a -> a
P.- a
1
        in (if a
count' a -> a -> Bool
forall a. Eq a => a -> a -> Bool
P.== a
0 then a -> Set a -> Set a
forall a. Ord a => a -> Set a -> Set a
Set.insert a
i Set a
queue else Set a
queue, a -> a -> Map a a -> Map a a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert a
i a
count' Map a a
remaining)
    go :: Set Int
-> Set Int
-> Map Int Int
-> [(Int, Box l Int)]
-> [Int]
-> Either String ([(Int, Box l Int)], [Int])
go Set Int
available Set Int
queue Map Int Int
remaining [(Int, Box l Int)]
acc [Int]
cutsRev = case Set Int -> Maybe (Int, Set Int)
forall a. Set a -> Maybe (a, Set a)
Set.minView Set Int
queue of
      Maybe (Int, Set Int)
P.Nothing -> case Map Int Int -> Maybe (Int, Int)
forall k a. Map k a -> Maybe (k, a)
M.lookupMin Map Int Int
remaining of
        Maybe (Int, Int)
P.Nothing -> ([(Int, Box l Int)], [Int])
-> Either String ([(Int, Box l Int)], [Int])
forall a b. b -> Either a b
P.Right ([(Int, Box l Int)] -> [(Int, Box l Int)]
forall a. [a] -> [a]
P.reverse [(Int, Box l Int)]
acc, [Int] -> [Int]
forall a. [a] -> [a]
P.reverse [Int]
cutsRev)
        P.Just (Int
i, Int
_)
          | Bool
canTrace ->
              let missing :: Set Int
missing = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs (Map Int (Box l Int)
table Map Int (Box l Int) -> Int -> Box l Int
forall k a. Ord k => Map k a -> k -> a
M.! Int
i)) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
available
                  ns :: [Int]
ns = Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
missing
                  (Set Int
next, Map Int Int
counts') = ((Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int))
-> (Set Int, Map Int Int) -> [Int] -> (Set Int, Map Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int)
release (Set Int
queue, Map Int Int
remaining) [Int]
ns
              in Set Int
-> Set Int
-> Map Int Int
-> [(Int, Box l Int)]
-> [Int]
-> Either String ([(Int, Box l Int)], [Int])
go (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
available Set Int
missing) Set Int
next Map Int Int
counts' [(Int, Box l Int)]
acc ([Int] -> [Int]
forall a. [a] -> [a]
P.reverse [Int]
ns [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [Int]
cutsRev)
          | Bool
P.otherwise -> String -> Either String ([(Int, Box l Int)], [Int])
forall a b. a -> Either a b
P.Left String
"readBack: a directed cycle requires a trace"
      P.Just (Int
i, Set Int
rest) ->
        let bx :: Box l Int
bx = Map Int (Box l Int)
table Map Int (Box l Int) -> Int -> Box l Int
forall k a. Ord k => Map k a -> k -> a
M.! Int
i
            fresh :: Set Int
fresh = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs Box l Int
bx) Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set Int
available
            (Set Int
next, Map Int Int
counts') = ((Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int))
-> (Set Int, Map Int Int) -> [Int] -> (Set Int, Map Int Int)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (Set Int, Map Int Int) -> Int -> (Set Int, Map Int Int)
release (Set Int
rest, Int -> Map Int Int -> Map Int Int
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Int
i Map Int Int
remaining) (Set Int -> [Int]
forall a. Set a -> [a]
Set.toList Set Int
fresh)
        in Set Int
-> Set Int
-> Map Int Int
-> [(Int, Box l Int)]
-> [Int]
-> Either String ([(Int, Box l Int)], [Int])
go (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
available Set Int
fresh) Set Int
next Map Int Int
counts' ((Int
i, Box l Int
bx) (Int, Box l Int) -> [(Int, Box l Int)] -> [(Int, Box l Int)]
forall a. a -> [a] -> [a]
: [(Int, Box l Int)]
acc) [Int]
cutsRev

-- ** Planning

-- Pack the existing order into earliest dependency layers. Feedback inputs are supplied by the
-- trace, independently of the outputs that close it.
boxLayers :: Scheduling -> [P.Int] -> [(P.Int, Box l P.Int)] -> [[(P.Int, Box l P.Int)]]
boxLayers :: forall l.
Scheduling -> [Int] -> [(Int, Box l Int)] -> [[(Int, Box l Int)]]
boxLayers Scheduling
Sequential [Int]
_ [(Int, Box l Int)]
order = ((Int, Box l Int) -> [(Int, Box l Int)])
-> [(Int, Box l Int)] -> [[(Int, Box l Int)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((Int, Box l Int) -> [(Int, Box l Int)] -> [(Int, Box l Int)]
forall a. a -> [a] -> [a]
: []) [(Int, Box l Int)]
order
boxLayers Scheduling
Layered [Int]
feedbackNodes [(Int, Box l Int)]
order =
  ([(Int, Box l Int)] -> [(Int, Box l Int)])
-> [[(Int, Box l Int)]] -> [[(Int, Box l Int)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap [(Int, Box l Int)] -> [(Int, Box l Int)]
forall a. [a] -> [a]
P.reverse (Map Int [(Int, Box l Int)] -> [[(Int, Box l Int)]]
forall k a. Map k a -> [a]
M.elems (([(Int, Box l Int)] -> [(Int, Box l Int)] -> [(Int, Box l Int)])
-> [(Int, [(Int, Box l Int)])] -> Map Int [(Int, Box l Int)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [(Int, Box l Int)] -> [(Int, Box l Int)] -> [(Int, Box l Int)]
forall a. [a] -> [a] -> [a]
(P.++) [(Int
t, [(Int, Box l Int)
bx]) | (Int
t, (Int, Box l Int)
bx) <- [(Int, (Int, Box l Int))]
placed]))
  where
    cut :: Set Int
cut = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int]
feedbackNodes
    (Map Int Int
_, [(Int, (Int, Box l Int))]
placed) = (Map Int Int
 -> (Int, Box l Int) -> (Map Int Int, (Int, (Int, Box l Int))))
-> Map Int Int
-> [(Int, Box l Int)]
-> (Map Int Int, [(Int, (Int, Box l Int))])
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL Map Int Int
-> (Int, Box l Int) -> (Map Int Int, (Int, (Int, Box l Int)))
place Map Int Int
forall k a. Map k a
M.empty [(Int, Box l Int)]
order
    place :: Map Int Int
-> (Int, Box l Int) -> (Map Int Int, (Int, (Int, Box l Int)))
place Map Int Int
made bx :: (Int, Box l Int)
bx@(Int
_, Box l Int
b) =
      let t :: P.Int
          t :: Int
t = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
P.maximum (Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int -> Int -> Map Int Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 Int
n Map Int Int
made | Int
n <- Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
b, Int
n Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
cut])
          made' :: Map Int Int
made' = (Int -> Map Int Int -> Map Int Int)
-> Map Int Int -> [Int] -> Map Int Int
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (\Int
n -> (Int -> Int -> Int) -> Int -> Int -> Map Int Int -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith Int -> Int -> Int
forall a. Ord a => a -> a -> a
P.max Int
n Int
t) Map Int Int
made (Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs Box l Int
b)
      in (Map Int Int
made', (Int
t, (Int, Box l Int)
bx))

-- Carried wires participate in layout as identity boxes, without adding hypergraph nodes.
data LayerEntry = LayerEntry
  { LayerEntry -> [Key]
entryInputs :: [Key]
  , LayerEntry -> [Key]
entryOutputs :: [Key]
  , LayerEntry -> Maybe Int
entryBox :: P.Maybe P.Int
  }

identityEntry :: Key -> LayerEntry
identityEntry :: Key -> LayerEntry
identityEntry Key
k = [Key] -> [Key] -> Maybe Int -> LayerEntry
LayerEntry [Key
k] [Key
k] Maybe Int
forall a. Maybe a
P.Nothing

gateEntry :: (P.Int -> Key) -> (P.Int, Box l P.Int) -> LayerEntry
gateEntry :: forall l. (Int -> Key) -> (Int, Box l Int) -> LayerEntry
gateEntry Int -> Key
made (Int
i, Box l Int
bx) = [Key] -> [Key] -> Maybe Int -> LayerEntry
LayerEntry ((Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN (Box l Int -> [Int]
forall l n. Box l n -> [n]
inputs Box l Int
bx)) ((Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
made (Box l Int -> [Int]
forall l n. Box l n -> [n]
outputs Box l Int
bx)) (Int -> Maybe Int
forall a. a -> Maybe a
P.Just Int
i)

-- Four alternating sweeps exchange adjacent entries only when the total estimated routing cost
-- decreases. Layer membership and each box's port order stay fixed; ties retain their order.
orderLayers
  :: (Key -> P.Integer) -> [Key] -> [Key] -> [[LayerEntry]] -> [[LayerEntry]]
orderLayers :: (Key -> Integer)
-> [Key] -> [Key] -> [[LayerEntry]] -> [[LayerEntry]]
orderLayers Key -> Integer
size [Key]
initial [Key]
wanted [[LayerEntry]]
layers0 =
  (Integer, [[LayerEntry]]) -> [[LayerEntry]]
forall a b. (a, b) -> b
P.snd (((Integer, [[LayerEntry]])
 -> [(Int, Int)] -> (Integer, [[LayerEntry]]))
-> (Integer, [[LayerEntry]])
-> [[(Int, Int)]]
-> (Integer, [[LayerEntry]])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Integer, [[LayerEntry]])
-> [(Int, Int)] -> (Integer, [[LayerEntry]])
sweep (Integer, [[LayerEntry]])
start [[(Int, Int)]]
passes)
  where
    -- Start identities near their incoming positions, even across several idle layers.
    -- Moving them one layer at a time can require cost-neutral swaps.
    seeded :: [[LayerEntry]]
seeded = ([Key], [[LayerEntry]]) -> [[LayerEntry]]
forall a b. (a, b) -> b
P.snd (([Key] -> [LayerEntry] -> ([Key], [LayerEntry]))
-> [Key] -> [[LayerEntry]] -> ([Key], [[LayerEntry]])
forall (t :: Type -> Type) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
List.mapAccumL [Key] -> [LayerEntry] -> ([Key], [LayerEntry])
seed [Key]
initial [[LayerEntry]]
layers0)
    seed :: [Key] -> [LayerEntry] -> ([Key], [LayerEntry])
seed [Key]
bundle [LayerEntry]
layer =
      let positions :: Map Key Int
positions = [(Key, Int)] -> Map Key Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Key] -> [Int] -> [(Key, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Key]
bundle [Int
0 :: P.Int ..])
          position :: LayerEntry -> Int
position LayerEntry
entry = [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Ord a) => t a -> a
P.minimum ([Key] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Key]
bundle Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
i | Key
k <- LayerEntry -> [Key]
entryInputs LayerEntry
entry, P.Just Int
i <- [Key -> Map Key Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
k Map Key Int
positions]])
          ordered :: [LayerEntry]
ordered = (LayerEntry -> Int) -> [LayerEntry] -> [LayerEntry]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn LayerEntry -> Int
position [LayerEntry]
layer
      in ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
ordered, [LayerEntry]
ordered)
    originalCost :: Integer
originalCost = [[LayerEntry]] -> Integer
cost [[LayerEntry]]
layers0
    seededCost :: Integer
seededCost = [[LayerEntry]] -> Integer
cost [[LayerEntry]]
seeded
    start :: (Integer, [[LayerEntry]])
start
      | Integer
originalCost Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
P.== Integer
0 Bool -> Bool -> Bool
P.|| Integer
originalCost Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
P.<= Integer
seededCost = (Integer
originalCost, [[LayerEntry]]
layers0)
      | Bool
P.otherwise = (Integer
seededCost, [[LayerEntry]]
seeded)
    cost :: [[LayerEntry]] -> Integer
cost [[LayerEntry]]
layers =
      [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
P.sum
        ( ([Key] -> [Key] -> Integer) -> [[Key]] -> [[Key]] -> [Integer]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
P.zipWith
            [Key] -> [Key] -> Integer
crossings
            ([Key]
initial [Key] -> [[Key]] -> [[Key]]
forall a. a -> [a] -> [a]
: ([LayerEntry] -> [Key]) -> [[LayerEntry]] -> [[Key]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs) [[LayerEntry]]
layers)
            (([LayerEntry] -> [Key]) -> [[LayerEntry]] -> [[Key]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryInputs) [[LayerEntry]]
layers [[Key]] -> [[Key]] -> [[Key]]
forall a. [a] -> [a] -> [a]
P.++ [[Key]
wanted])
        )
    -- Shared wires use the same position; Frobenius merging is an estimate of spider routing.
    crossings :: [Key] -> [Key] -> Integer
crossings [Key]
from [Key]
to =
      let positions :: Map Key Int
positions = [(Key, Int)] -> Map Key Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Key] -> [Int] -> [(Key, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Key]
from [Int
0 :: P.Int ..])
          edges :: [(Int, Integer)]
edges = [(Int
i, Key -> Integer
size Key
k) | Key
k <- [Key]
to, P.Just Int
i <- [Key -> Map Key Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Key
k Map Key Int
positions]]
      in [(Int, Integer)] -> Integer
weightedInversions [(Int, Integer)]
edges
    passes :: [[(P.Int, P.Int)]]
    passes :: [[(Int, Int)]]
passes = [[(Int, Int)]
forward, [(Int, Int)]
backward, [(Int, Int)]
forward, [(Int, Int)]
backward]
    forward :: [(Int, Int)]
forward = [(Int
i, Int
j) | (Int
i, [LayerEntry]
layer) <- [Int] -> [[LayerEntry]] -> [(Int, [LayerEntry])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [[LayerEntry]]
layers0, Int
j <- [Int
0 .. [LayerEntry] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [LayerEntry]
layer Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
2]]
    backward :: [(Int, Int)]
backward = [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a]
P.reverse [(Int, Int)]
forward
    sweep :: (Integer, [[LayerEntry]])
-> [(Int, Int)] -> (Integer, [[LayerEntry]])
sweep current :: (Integer, [[LayerEntry]])
current@(Integer
0, [[LayerEntry]]
_) [(Int, Int)]
_ = (Integer, [[LayerEntry]])
current
    sweep (Integer, [[LayerEntry]])
current [] = (Integer, [[LayerEntry]])
current
    sweep (Integer, [[LayerEntry]])
current ((Int, Int)
move : [(Int, Int)]
rest) = (Integer, [[LayerEntry]])
-> [(Int, Int)] -> (Integer, [[LayerEntry]])
sweep ((Integer, [[LayerEntry]])
-> (Int, Int) -> (Integer, [[LayerEntry]])
improve (Integer, [[LayerEntry]])
current (Int, Int)
move) [(Int, Int)]
rest
    improve :: (Integer, [[LayerEntry]])
-> (Int, Int) -> (Integer, [[LayerEntry]])
improve current :: (Integer, [[LayerEntry]])
current@(Integer
best, [[LayerEntry]]
layers) (Int
i, Int
j) = case Int -> [[LayerEntry]] -> ([[LayerEntry]], [[LayerEntry]])
forall a. Int -> [a] -> ([a], [a])
P.splitAt Int
i [[LayerEntry]]
layers of
      ([[LayerEntry]]
pre, [LayerEntry]
layer : [[LayerEntry]]
rest) ->
        let from :: [Key]
from = case [[LayerEntry]] -> [[LayerEntry]]
forall a. [a] -> [a]
P.reverse [[LayerEntry]]
pre of
              [] -> [Key]
initial
              [LayerEntry]
previous : [[LayerEntry]]
_ -> (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
previous
            to :: [Key]
to = case [[LayerEntry]]
rest of
              [] -> [Key]
wanted
              [LayerEntry]
following : [[LayerEntry]]
_ -> (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryInputs [LayerEntry]
following
            -- Reordering a layer changes only its incoming and outgoing frontiers.
            localCost :: [LayerEntry] -> Integer
localCost [LayerEntry]
entries = [Key] -> [Key] -> Integer
crossings [Key]
from ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryInputs [LayerEntry]
entries) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ [Key] -> [Key] -> Integer
crossings ((LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
entries) [Key]
to
            candidate :: [LayerEntry]
candidate = Int -> [LayerEntry] -> [LayerEntry]
forall a. Int -> [a] -> [a]
exchangeAt Int
j [LayerEntry]
layer
            next :: Integer
next = Integer
best Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ [LayerEntry] -> Integer
localCost [LayerEntry]
candidate Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.- [LayerEntry] -> Integer
localCost [LayerEntry]
layer
        in if Integer
next Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
P.< Integer
best then (Integer
next, [[LayerEntry]]
pre [[LayerEntry]] -> [[LayerEntry]] -> [[LayerEntry]]
forall a. [a] -> [a] -> [a]
P.++ ([LayerEntry]
candidate [LayerEntry] -> [[LayerEntry]] -> [[LayerEntry]]
forall a. a -> [a] -> [a]
: [[LayerEntry]]
rest)) else (Integer, [[LayerEntry]])
current
      ([[LayerEntry]], [[LayerEntry]])
_ -> (Integer, [[LayerEntry]])
current
    exchangeAt :: Int -> [a] -> [a]
exchangeAt Int
n [a]
xs = case Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
P.splitAt Int
n [a]
xs of
      ([a]
pre, a
a : a
b : [a]
rest) -> [a]
pre [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
P.++ (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
: a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
rest)
      ([a], [a])
_ -> [a]
xs

-- Crossing costs use Integer so large object sizes do not overflow during comparison.
weightedInversions :: [(P.Int, P.Integer)] -> P.Integer
weightedInversions :: [(Int, Integer)] -> Integer
weightedInversions [(Int, Integer)]
edges = [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
P.sum [Integer
a Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.* Integer
b | (Int
i, Integer
a) : [(Int, Integer)]
rest <- [(Int, Integer)] -> [[(Int, Integer)]]
forall a. [a] -> [[a]]
List.tails [(Int, Integer)]
edges, (Int
j, Integer
b) <- [(Int, Integer)]
rest, Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.> Int
j]

-- Reorder the exposed wires of proper subtrees. Changing one boundary affects only its own
-- transition and its parent's, so each accepted swap reduces their combined routing cost.
-- The root boundary, contraction tree and the indices eliminated at each node stay fixed.
routeTree :: (Key -> P.Integer) -> Tree -> Tree
routeTree :: (Key -> Integer) -> Tree -> Tree
routeTree Key -> Integer
size Tree
t0 = (Tree -> Bool -> Tree) -> Tree -> [Bool] -> Tree
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (\Tree
t Bool
backwards -> Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards (Integer -> [Key] -> Integer
forall a b. a -> b -> a
P.const Integer
0) Bool
P.False Tree
t) Tree
t0 [Bool]
passes
  where
    passes :: [P.Bool]
    passes :: [Bool]
passes = [Bool
P.False, Bool
P.True, Bool
P.False, Bool
P.True]
    visit :: Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards [Key] -> Integer
above Bool
movable Tree
t =
      let rebuilt :: Tree
rebuilt = case Tree
t of
            Leaf{} -> Tree
t
            Merge Tree
l Tree
r [Key]
ks
              | Bool
backwards ->
                  let r' :: Tree
r' = Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards (\[Key]
out -> [Key] -> [Key] -> Integer
routingCost (Tree -> [Key]
treeKeys Tree
l [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
out) [Key]
ks) Bool
P.True Tree
r
                      l' :: Tree
l' = Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards (\[Key]
out -> [Key] -> [Key] -> Integer
routingCost ([Key]
out [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ Tree -> [Key]
treeKeys Tree
r') [Key]
ks) Bool
P.True Tree
l
                  in Tree -> Tree -> [Key] -> Tree
Merge Tree
l' Tree
r' [Key]
ks
              | Bool
P.otherwise ->
                  let l' :: Tree
l' = Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards (\[Key]
out -> [Key] -> [Key] -> Integer
routingCost ([Key]
out [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ Tree -> [Key]
treeKeys Tree
r) [Key]
ks) Bool
P.True Tree
l
                      r' :: Tree
r' = Bool -> ([Key] -> Integer) -> Bool -> Tree -> Tree
visit Bool
backwards (\[Key]
out -> [Key] -> [Key] -> Integer
routingCost (Tree -> [Key]
treeKeys Tree
l' [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
out) [Key]
ks) Bool
P.True Tree
r
                  in Tree -> Tree -> [Key] -> Tree
Merge Tree
l' Tree
r' [Key]
ks
          cost :: Tree -> Integer
cost Tree
tree = [Key] -> [Key] -> Integer
routingCost (Tree -> [Key]
treeMade Tree
tree) (Tree -> [Key]
treeKeys Tree
tree) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ [Key] -> Integer
above (Tree -> [Key]
treeKeys Tree
tree)
          positions :: [Int]
positions = [Int
0 .. [Key] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length (Tree -> [Key]
treeKeys Tree
rebuilt) Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
2]
          improve :: (Integer, Tree) -> Int -> (Integer, Tree)
improve current :: (Integer, Tree)
current@(Integer
best, Tree
tree) Int
i =
            let ks :: [Key]
ks = Tree -> [Key]
treeKeys Tree
tree
                candidate :: Tree
candidate = case Int -> [Key] -> ([Key], [Key])
forall a. Int -> [a] -> ([a], [a])
P.splitAt Int
i [Key]
ks of
                  ([Key]
pre, Key
a : Key
b : [Key]
rest) -> [Key] -> Tree -> Tree
setKeys ([Key]
pre [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ (Key
b Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: Key
a Key -> [Key] -> [Key]
forall a. a -> [a] -> [a]
: [Key]
rest)) Tree
tree
                  ([Key], [Key])
_ -> Tree
tree
                next :: Integer
next = Tree -> Integer
cost Tree
candidate
            in if Integer
next Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
P.< Integer
best then (Integer
next, Tree
candidate) else (Integer, Tree)
current
      in if Bool
movable
           then (Integer, Tree) -> Tree
forall a b. (a, b) -> b
P.snd (((Integer, Tree) -> Int -> (Integer, Tree))
-> (Integer, Tree) -> [Int] -> (Integer, Tree)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' (Integer, Tree) -> Int -> (Integer, Tree)
improve (Tree -> Integer
cost Tree
rebuilt, Tree
rebuilt) (if Bool
backwards then [Int] -> [Int]
forall a. [a] -> [a]
P.reverse [Int]
positions else [Int]
positions))
           else Tree
rebuilt
    setKeys :: [Key] -> Tree -> Tree
setKeys [Key]
ks (Leaf Int
i [Key]
made [Key]
_) = Int -> [Key] -> [Key] -> Tree
Leaf Int
i [Key]
made [Key]
ks
    setKeys [Key]
ks (Merge Tree
l Tree
r [Key]
_) = Tree -> Tree -> [Key] -> Tree
Merge Tree
l Tree
r [Key]
ks
    routingCost :: [Key] -> [Key] -> Integer
routingCost [Key]
from [Key]
to =
      let kinds :: [Key]
kinds = [Key] -> [Key] -> [Key] -> [Key]
groupOrder [Key]
from [Key]
to ([Key] -> [Key]
forall a. Ord a => [a] -> [a]
nubOrd ([Key]
from [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
to))
          ranks :: Map Key Int
ranks = [(Key, Int)] -> Map Key Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Key] -> [Int] -> [(Key, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Key]
kinds [Int
0 :: P.Int ..])
          grouped :: [Key] -> Integer
grouped [Key]
wires = [(Int, Integer)] -> Integer
weightedInversions [(Map Key Int
ranks Map Key Int -> Key -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Key
k, Key -> Integer
size Key
k) | Key
k <- [Key]
wires]
      in [Key] -> Integer
grouped [Key]
from Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ [Key] -> Integer
grouped [Key]
to

-- Route each frontier and tensor its gates with the identities of the carried wires.
buildLayers
  :: forall s (xs :: [s])
   . (SymMonoidal s)
  => Align s
  -> (forall ws. [Key] -> [Key] -> Built (ws :: [s]) -> Built ws)
  -> M.Map P.Int (SomeArrow s)
  -> [Key]
  -> Built xs
  -> [[LayerEntry]]
  -> ([Key], Built xs)
buildLayers :: forall s (xs :: [s]).
SymMonoidal s =>
Align s
-> (forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws)
-> Map Int (SomeArrow s)
-> [Key]
-> Built xs
-> [[LayerEntry]]
-> ([Key], Built xs)
buildLayers Align s
al forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws
route Map Int (SomeArrow s)
arrows = [Key] -> Built xs -> [[LayerEntry]] -> ([Key], Built xs)
go
  where
    go :: [Key] -> Built xs -> [[LayerEntry]] -> ([Key], Built xs)
    go :: [Key] -> Built xs -> [[LayerEntry]] -> ([Key], Built xs)
go [Key]
bundle Built xs
body [] = ([Key]
bundle, Built xs
body)
    go [Key]
bundle Built xs
body ([LayerEntry]
layer : [[LayerEntry]]
rest) =
      let need :: [Key]
need = (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryInputs [LayerEntry]
layer
          made :: [Key]
made = (LayerEntry -> [Key]) -> [LayerEntry] -> [Key]
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> [b]) -> t a -> [b]
P.concatMap LayerEntry -> [Key]
entryOutputs [LayerEntry]
layer
          run :: forall ws. Sorts (ws :: [s]) -> Built ws
          run :: forall (ws :: [s]). Sorts ws -> Built ws
run = [LayerEntry] -> Sorts ws -> Built ws
forall (ws :: [s]). [LayerEntry] -> Sorts ws -> Built ws
build [LayerEntry]
layer
      in [Key] -> Built xs -> [[LayerEntry]] -> ([Key], Built xs)
go [Key]
made (Sorts ys -> Built ys
forall (ws :: [s]). Sorts ws -> Built ws
run (forall (ws :: [s]). Sorts ws -> Built ws) -> Built xs -> Built xs
forall {s} (xs :: [s]).
Monoidal s =>
(forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
`afterBuilt` [Key] -> [Key] -> Built xs -> Built xs
forall (ws :: [s]). [Key] -> [Key] -> Built ws -> Built ws
route [Key]
bundle [Key]
need Built xs
body) [[LayerEntry]]
rest
    build :: forall ws. [LayerEntry] -> Sorts (ws :: [s]) -> Built ws
    build :: forall (ws :: [s]). [LayerEntry] -> Sorts ws -> Built ws
build [] Sorts ws
ws = Sorts ws -> Step ws ws -> Built ws
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts ws
ws Step ws ws
forall {s} (xs :: [s]). Step xs xs
Same
    build (LayerEntry
entry : [LayerEntry]
rest) Sorts ws
ws = case LayerEntry -> Maybe Int
entryBox LayerEntry
entry of
      Maybe Int
P.Nothing ->
        let ([LayerEntry]
identities, [LayerEntry]
remaining) = (LayerEntry -> Bool)
-> [LayerEntry] -> ([LayerEntry], [LayerEntry])
forall a. (a -> Bool) -> [a] -> ([a], [a])
P.span (Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int -> Bool)
-> (LayerEntry -> Maybe Int) -> LayerEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. LayerEntry -> Maybe Int
entryBox) [LayerEntry]
rest
        in Int
-> (forall (ws :: [s]). Sorts ws -> Built ws)
-> Sorts ws
-> Built ws
forall {s} (xs :: [s]).
Monoidal s =>
Int
-> (forall (ys :: [s]). Sorts ys -> Built ys)
-> Sorts xs
-> Built xs
carryThen (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ [LayerEntry] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [LayerEntry]
identities) ([LayerEntry] -> Sorts ys -> Built ys
forall (ws :: [s]). [LayerEntry] -> Sorts ws -> Built ws
build [LayerEntry]
remaining) Sorts ws
ws
      P.Just Int
i -> case Map Int (SomeArrow s)
arrows Map Int (SomeArrow s) -> Int -> SomeArrow s
forall k a. Ord k => Map k a -> k -> a
M.! Int
i of
        arrow :: SomeArrow s
arrow@(SomeArrow Sorts as
ins Sorts bs
_ as ~> bs
_) -> case [LayerEntry]
rest of
          [] -> Align s -> SomeArrow s -> Sorts ws -> Built ws
forall s (xs :: [s]).
Monoidal s =>
Align s -> SomeArrow s -> Sorts xs -> Built xs
boxThen Maybe (Step '[x] '[y])
Align s
al SomeArrow s
arrow Sorts ws
ws
          [LayerEntry]
_ -> Int
-> Sorts ws
-> (forall (pre :: [s]) (post :: [s]).
    (ws ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> Built ws)
-> Built ws
forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts (Sorts as -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf Sorts as
ins) Sorts ws
ws \Sorts pre
pre Sorts post
post -> Sorts pre
-> Built pre -> Sorts post -> Built post -> Built (pre ++ post)
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts pre
pre (Align s -> SomeArrow s -> Sorts pre -> Built pre
forall s (xs :: [s]).
Monoidal s =>
Align s -> SomeArrow s -> Sorts xs -> Built xs
boxThen Maybe (Step '[x] '[y])
Align s
al SomeArrow s
arrow Sorts pre
pre) Sorts post
post ([LayerEntry] -> Sorts post -> Built post
forall (ws :: [s]). [LayerEntry] -> Sorts ws -> Built ws
build [LayerEntry]
rest Sorts post
post)

-- | The nodes of an open hypergraph, numbered from 0, and its boundaries.
data Shape = Shape {Shape -> [Int]
shapeNodes :: [P.Int], Shape -> [Int]
shapeIns :: [P.Int], Shape -> [Int]
shapeOuts :: [P.Int]}

-- | A numbered box.
type Ix = (P.Int, Box () P.Int)

touches :: Ix -> Set.Set P.Int
touches :: (Int, Box () Int) -> Set Int
touches (Int
_, Box () Int
bx) = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Box () Int -> [Int]
forall l n. Box l n -> [n]
outputs Box () Int
bx)

without :: Ix -> [Ix] -> [Ix]
without :: (Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
bx = ((Int, Box () Int) -> Bool)
-> [(Int, Box () Int)] -> [(Int, Box () Int)]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (\(Int, Box () Int)
b -> (Int, Box () Int) -> Int
forall a b. (a, b) -> a
P.fst (Int, Box () Int)
b Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P./= (Int, Box () Int) -> Int
forall a b. (a, b) -> a
P.fst (Int, Box () Int)
bx)

-- | The nodes that the given boxes or the outputs need.
neededBy :: Shape -> [Ix] -> Set.Set P.Int
neededBy :: Shape -> [(Int, Box () Int)] -> Set Int
neededBy Shape
sh [(Int, Box () Int)]
rest = [Set Int] -> Set Int
forall (f :: Type -> Type) a.
(Foldable f, Ord a) =>
f (Set a) -> Set a
Set.unions ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeOuts Shape
sh) Set Int -> [Set Int] -> [Set Int]
forall a. a -> [a] -> [a]
: [(Int, Box () Int) -> Set Int
touches (Int, Box () Int)
b | (Int, Box () Int)
b <- [(Int, Box () Int)]
rest])

-- | The nodes that are open once the placed nodes are in, with the given boxes still to come.
openAfter :: Shape -> Set.Set P.Int -> [Ix] -> Set.Set P.Int
openAfter :: Shape -> Set Int -> [(Int, Box () Int)] -> Set Int
openAfter Shape
sh Set Int
placed [(Int, Box () Int)]
rest = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeIns Shape
sh)) Set Int
placed) (Shape -> [(Int, Box () Int)] -> Set Int
neededBy Shape
sh [(Int, Box () Int)]
rest)

-- | What is left of a box on its own, among the given boxes: its nodes that the boundary or another
-- box needs.
alone :: Shape -> [Ix] -> Ix -> Set.Set P.Int
alone :: Shape -> [(Int, Box () Int)] -> (Int, Box () Int) -> Set Int
alone Shape
sh [(Int, Box () Int)]
bxs (Int, Box () Int)
bx = Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
bx) (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeIns Shape
sh)) (Shape -> [(Int, Box () Int)] -> Set Int
neededBy Shape
sh ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
bx [(Int, Box () Int)]
bxs)))

-- | How much a contraction makes the result grow: the size of the result less the sizes of the two
-- parts, which numpy's greedy order keeps smallest.
gain :: (Set.Set P.Int -> P.Double) -> Set.Set P.Int -> Set.Set P.Int -> Set.Set P.Int -> P.Double
gain :: (Set Int -> Double) -> Set Int -> Set Int -> Set Int -> Double
gain Set Int -> Double
size Set Int
whole Set Int
a Set Int
b = Set Int -> Double
size Set Int
whole Double -> Double -> Double
forall a. Num a => a -> a -> a
P.- Set Int -> Double
size Set Int
a Double -> Double -> Double
forall a. Num a => a -> a -> a
P.- Set Int -> Double
size Set Int
b

-- | Some of the boxes without inputs, contracted as a tree, with how many of them touch each node.
data Piece = Piece {Piece -> Tree
pieceTree :: Tree, Piece -> Map Int Int
pieceCounts :: M.Map P.Int P.Int}

-- | The boxes without inputs contracted with each other as a tree, until no two share a node, in
-- the order of 'planContraction'.
contractStates :: (Set.Set P.Int -> P.Double) -> Shape -> [Ix] -> [Piece]
contractStates :: (Set Int -> Double) -> Shape -> [(Int, Box () Int)] -> [Piece]
contractStates Set Int -> Double
size Shape
sh [(Int, Box () Int)]
bxs = (Plan -> Piece) -> [Plan] -> [Piece]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Plan -> Piece
run ((Set Int -> Double)
-> (Int -> Bool) -> Set Int -> [Set Int] -> [Plan]
forall n.
Ord n =>
(Set n -> Double) -> (n -> Bool) -> Set n -> [Set n] -> [Plan]
planContraction Set Int -> Double
size (Bool -> Int -> Bool
forall a b. a -> b -> a
P.const Bool
P.True) Set Int
needed (((Int, Box () Int) -> Set Int) -> [(Int, Box () Int)] -> [Set Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Int, Box () Int) -> Set Int
touches [(Int, Box () Int)]
states))
  where
    states :: [(Int, Box () Int)]
states = [(Int, Box () Int)
b | b :: (Int, Box () Int)
b@(Int
_, Box () Int
bx) <- [(Int, Box () Int)]
bxs, [Int] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
P.null (Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx)]
    -- the nodes of the boundary and of the boxes with inputs
    needed :: Set Int
needed =
      [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList
        (Shape -> [Int]
shapeIns Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Shape -> [Int]
shapeOuts Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [Int
n | b :: (Int, Box () Int)
b@(Int
_, Box () Int
bx) <- [(Int, Box () Int)]
bxs, Bool -> Bool
P.not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
P.null (Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx)), Int
n <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
b)])
    run :: Plan -> Piece
run (Factor Int
k) = (Int, Box () Int) -> Piece
leaf ([(Int, (Int, Box () Int))] -> Map Int (Int, Box () Int)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([Int] -> [(Int, Box () Int)] -> [(Int, (Int, Box () Int))]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] [(Int, Box () Int)]
states) Map Int (Int, Box () Int) -> Int -> (Int, Box () Int)
forall k a. Ord k => Map k a -> k -> a
M.! Int
k)
    run (Contract Plan
a Plan
b) = Piece -> Piece -> Piece
merge (Plan -> Piece
run Plan
a) (Plan -> Piece
run Plan
b)
    -- how many boxes and boundaries touch each node; a piece needs to keep a node that they touch
    -- more often than its own boxes do
    total :: Map Int Int
total =
      (Int -> Int -> Int) -> [(Int, Int)] -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
        Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+)
        ([(Int
n, Int
1) | (Int, Box () Int)
b <- [(Int, Box () Int)]
bxs, Int
n <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
b)] [(Int, Int)] -> [(Int, Int)] -> [(Int, Int)]
forall a. [a] -> [a] -> [a]
P.++ [(Int
n, Int
1) | Int
n <- [Int] -> [Int]
forall a. Ord a => [a] -> [a]
nubOrd (Shape -> [Int]
shapeIns Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Shape -> [Int]
shapeOuts Shape
sh)])
    openIn :: Map Int Int -> Set Int
openIn Map Int Int
counts = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList [Int
n | (Int
n, Int
c) <- Map Int Int -> [(Int, Int)]
forall k a. Map k a -> [(k, a)]
M.toList Map Int Int
counts, Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.< Map Int Int
total Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Int
n]
    keysIn :: Set Int -> [Key] -> [Key]
keysIn Set Int
open [Key]
made = [Key
k | Key
k <- [Key] -> [Key]
forall a. Ord a => [a] -> [a]
nubOrd [Key]
made, Key -> Int
keyNode Key
k Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set Int
open]
    leaf :: (Int, Box () Int) -> Piece
leaf b :: (Int, Box () Int)
b@(Int
i, Box () Int
bx) =
      let counts :: Map Int Int
counts = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
n, Int
1) | Int
n <- Set Int -> [Int]
forall a. Set a -> [a]
Set.toList ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
b)]
          open :: Set Int
open = Map Int Int -> Set Int
openIn Map Int Int
counts
      in Tree -> Map Int Int -> Piece
Piece (Int -> [Key] -> [Key] -> Tree
Leaf Int
i ((Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN (Box () Int -> [Int]
forall l n. Box l n -> [n]
outputs Box () Int
bx)) (Set Int -> [Key] -> [Key]
keysIn Set Int
open ((Int -> Key) -> [Int] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Int -> Key
KN (Box () Int -> [Int]
forall l n. Box l n -> [n]
outputs Box () Int
bx)))) Map Int Int
counts
    merge :: Piece -> Piece -> Piece
merge Piece
a Piece
b =
      let counts :: Map Int Int
counts = (Int -> Int -> Int) -> Map Int Int -> Map Int Int -> Map Int Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) (Piece -> Map Int Int
pieceCounts Piece
a) (Piece -> Map Int Int
pieceCounts Piece
b)
          open :: Set Int
open = Map Int Int -> Set Int
openIn Map Int Int
counts
      in Tree -> Map Int Int -> Piece
Piece (Tree -> Tree -> [Key] -> Tree
Merge (Piece -> Tree
pieceTree Piece
a) (Piece -> Tree
pieceTree Piece
b) (Set Int -> [Key] -> [Key]
keysIn Set Int
open (Tree -> [Key]
treeKeys (Piece -> Tree
pieceTree Piece
a) [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ Tree -> [Key]
treeKeys (Piece -> Tree
pieceTree Piece
b)))) Map Int Int
counts

-- | The boxes read back along a path: those with inputs, the states left on their own, and one box
-- for each piece of more than one state, numbered after the boxes, with those pieces.
pathBoxes :: [Ix] -> [Piece] -> ([Ix], [(P.Int, Tree)])
pathBoxes :: [(Int, Box () Int)]
-> [Piece] -> ([(Int, Box () Int)], [(Int, Tree)])
pathBoxes [(Int, Box () Int)]
bxs [Piece]
pieces =
  ( [(Int, Box () Int)
b | b :: (Int, Box () Int)
b@(Int
i, Box () Int
bx) <- [(Int, Box () Int)]
bxs, Bool -> Bool
P.not ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
P.null (Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx)) Bool -> Bool -> Bool
P.|| Int
i Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` [Int]
alone']
      [(Int, Box () Int)] -> [(Int, Box () Int)] -> [(Int, Box () Int)]
forall a. [a] -> [a] -> [a]
P.++ [(Int
j, () -> [Int] -> [Int] -> Box () Int
forall l n. l -> [n] -> [n] -> Box l n
Box () [] ((Key -> Int) -> [Key] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Key -> Int
keyNode (Tree -> [Key]
treeKeys Tree
t))) | (Int
j, Tree
t) <- [(Int, Tree)]
merged]
  , [(Int, Tree)]
merged
  )
  where
    alone' :: [Int]
alone' = [Int
i | Piece{pieceTree :: Piece -> Tree
pieceTree = Leaf Int
i [Key]
_ [Key]
_} <- [Piece]
pieces]
    merged :: [(Int, Tree)]
merged = [(Int
j, Tree
t) | (Int
j, Piece{pieceTree :: Piece -> Tree
pieceTree = t :: Tree
t@Merge{}}) <- [Int] -> [Piece] -> [(Int, Piece)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [[(Int, Box () Int)] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [(Int, Box () Int)]
bxs ..] [Piece]
pieces]

-- | The boxes one at a time, in numpy's greedy order: of the boxes whose inputs are made, the one
-- whose contraction with the open nodes costs least, or the first of the cheapest pair while no node
-- is open; a box on a cycle when no box is ready.
schedule :: (Set.Set P.Int -> P.Double) -> Shape -> [Ix] -> [Ix]
schedule :: (Set Int -> Double)
-> Shape -> [(Int, Box () Int)] -> [(Int, Box () Int)]
schedule Set Int -> Double
size Shape
sh [(Int, Box () Int)]
bxs = Set Int -> [(Int, Box () Int)] -> [(Int, Box () Int)]
go Set Int
forall a. Set a
Set.empty [(Int, Box () Int)]
bxs
  where
    go :: Set Int -> [(Int, Box () Int)] -> [(Int, Box () Int)]
go Set Int
_ [] = []
    go Set Int
placed [(Int, Box () Int)]
remaining =
      let open :: Set Int
open = Shape -> Set Int -> [(Int, Box () Int)] -> Set Int
openAfter Shape
sh Set Int
placed [(Int, Box () Int)]
remaining
          after :: (Int, Box () Int) -> Set Int
after (Int, Box () Int)
bx = Shape -> Set Int -> [(Int, Box () Int)] -> Set Int
openAfter Shape
sh (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
placed ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
bx)) ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
bx [(Int, Box () Int)]
remaining)
          cost :: (Int, Box () Int) -> Double
cost (Int, Box () Int)
bx = (Set Int -> Double) -> Set Int -> Set Int -> Set Int -> Double
gain Set Int -> Double
size ((Int, Box () Int) -> Set Int
after (Int, Box () Int)
bx) Set Int
open (Shape -> [(Int, Box () Int)] -> (Int, Box () Int) -> Set Int
alone Shape
sh [(Int, Box () Int)]
bxs (Int, Box () Int)
bx)
          pairCost :: ((Int, Box () Int), (Int, Box () Int)) -> Double
pairCost ((Int, Box () Int)
x, (Int, Box () Int)
y) =
            (Set Int -> Double) -> Set Int -> Set Int -> Set Int -> Double
gain
              Set Int -> Double
size
              (Shape -> Set Int -> [(Int, Box () Int)] -> Set Int
openAfter Shape
sh (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
placed (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
x) ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
y))) ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
y ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
x [(Int, Box () Int)]
remaining)))
              (Shape -> [(Int, Box () Int)] -> (Int, Box () Int) -> Set Int
alone Shape
sh [(Int, Box () Int)]
bxs (Int, Box () Int)
x)
              (Shape -> [(Int, Box () Int)] -> (Int, Box () Int) -> Set Int
alone Shape
sh [(Int, Box () Int)]
bxs (Int, Box () Int)
y)
          next :: (Int, Box () Int)
next
            | Set Int -> Bool
forall a. Set a -> Bool
Set.null Set Int
open
            , (Int, Box () Int)
_ : (Int, Box () Int)
_ : [(Int, Box () Int)]
_ <- [(Int, Box () Int)]
remaining =
                ((Int, Box () Int), (Int, Box () Int)) -> (Int, Box () Int)
forall a b. (a, b) -> a
P.fst ((((Int, Box () Int), (Int, Box () Int))
 -> ((Int, Box () Int), (Int, Box () Int)) -> Ordering)
-> [((Int, Box () Int), (Int, Box () Int))]
-> ((Int, Box () Int), (Int, Box () Int))
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy ((((Int, Box () Int), (Int, Box () Int)) -> Double)
-> ((Int, Box () Int), (Int, Box () Int))
-> ((Int, Box () Int), (Int, Box () Int))
-> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Int, Box () Int), (Int, Box () Int)) -> Double
pairCost) [((Int, Box () Int)
x, (Int, Box () Int)
y) | (Int, Box () Int)
x <- [(Int, Box () Int)] -> [(Int, Box () Int)]
forall {a} {a} {l}.
(Eq a, Eq a) =>
[(a, Box l a)] -> [(a, Box l a)]
candidates [(Int, Box () Int)]
remaining, (Int, Box () Int)
y <- [(Int, Box () Int)] -> [(Int, Box () Int)]
forall {a} {a} {l}.
(Eq a, Eq a) =>
[(a, Box l a)] -> [(a, Box l a)]
candidates ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
x [(Int, Box () Int)]
remaining)])
            | Bool
P.otherwise = ((Int, Box () Int) -> (Int, Box () Int) -> Ordering)
-> [(Int, Box () Int)] -> (Int, Box () Int)
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (((Int, Box () Int) -> Double)
-> (Int, Box () Int) -> (Int, Box () Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Box () Int) -> Double
cost) ([(Int, Box () Int)] -> [(Int, Box () Int)]
forall {a} {a} {l}.
(Eq a, Eq a) =>
[(a, Box l a)] -> [(a, Box l a)]
candidates [(Int, Box () Int)]
remaining)
      in (Int, Box () Int)
next (Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
forall a. a -> [a] -> [a]
: Set Int -> [(Int, Box () Int)] -> [(Int, Box () Int)]
go (Set Int -> Set Int -> Set Int
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Int
placed ((Int, Box () Int) -> Set Int
touches (Int, Box () Int)
next)) ((Int, Box () Int) -> [(Int, Box () Int)] -> [(Int, Box () Int)]
without (Int, Box () Int)
next [(Int, Box () Int)]
remaining)
    candidates :: [(a, Box l a)] -> [(a, Box l a)]
candidates [(a, Box l a)]
remaining = case [(a, Box l a)
bx | (a, Box l a)
bx <- [(a, Box l a)]
remaining, Bool -> Bool
P.not (((a, Box l a) -> Bool) -> [(a, Box l a)] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.any ((a, Box l a) -> (a, Box l a) -> Bool
forall {a} {a} {l} {l}.
(Eq a, Eq a) =>
(a, Box l a) -> (a, Box l a) -> Bool
dependsOn (a, Box l a)
bx) [(a, Box l a)]
remaining)] of
      [] -> Int -> [(a, Box l a)] -> [(a, Box l a)]
forall a. Int -> [a] -> [a]
P.take Int
1 [(a, Box l a)]
remaining
      [(a, Box l a)]
ready -> [(a, Box l a)]
ready
    -- a box depends on another when it uses a node the other makes
    dependsOn :: (a, Box l a) -> (a, Box l a) -> Bool
dependsOn (a
i, Box l a
bi) (a
j, Box l a
bj) = a
i a -> a -> Bool
forall a. Eq a => a -> a -> Bool
P./= a
j Bool -> Bool -> Bool
P.&& (a -> Bool) -> [a] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.any (a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` Box l a -> [a]
forall l n. Box l n -> [n]
outputs Box l a
bj) (Box l a -> [a]
forall l n. Box l n -> [n]
inputs Box l a
bi)

-- | When the wires of the read-back are needed, for the boxes in the given order.
data Lifetimes = Lifetimes
  { Lifetimes -> [Int]
feedback :: [P.Int]
  -- ^ the nodes that a box uses no later than a box makes them, fed back with a trace
  , Lifetimes -> Int -> Key
outKey :: P.Int -> Key
  -- ^ the wire that a box makes of a node
  , Lifetimes -> Int -> Key -> Bool
live :: P.Int -> Key -> P.Bool
  -- ^ whether a wire is needed after the given step: a later box uses it or makes another part of
  -- it, or it is an output; what boxes make of a node fed back goes on its other wire, to the end
  }

lifetimes :: Shape -> [Ix] -> [[Ix]] -> Lifetimes
lifetimes :: Shape -> [(Int, Box () Int)] -> [[(Int, Box () Int)]] -> Lifetimes
lifetimes Shape
sh [(Int, Box () Int)]
bxs [[(Int, Box () Int)]]
layers = Lifetimes{feedback :: [Int]
feedback = [Int]
fb, outKey :: Int -> Key
outKey = Int -> Key
key, live :: Int -> Key -> Bool
live = Int -> Key -> Bool
alive}
  where
    layerOf :: Map Int Int
layerOf = [(Int, Int)] -> Map Int Int
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Int
i, Int
t) | (Int
t, [(Int, Box () Int)]
layer) <- [Int] -> [[(Int, Box () Int)]] -> [(Int, [(Int, Box () Int)])]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
1 :: P.Int ..] [[(Int, Box () Int)]]
layers, (Int
i, Box () Int
_) <- [(Int, Box () Int)]
layer]
    madeAt :: Map Int [Int]
madeAt = ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(P.++) [(Int
n, [Map Int Int
layerOf Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Int
i]) | (Int
i, Box () Int
bx) <- [(Int, Box () Int)]
bxs, Int
n <- Box () Int -> [Int]
forall l n. Box l n -> [n]
outputs Box () Int
bx]
    usedAt :: Map Int [Int]
usedAt = ([Int] -> [Int] -> [Int]) -> [(Int, [Int])] -> Map Int [Int]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
(P.++) [(Int
n, [Map Int Int
layerOf Map Int Int -> Int -> Int
forall k a. Ord k => Map k a -> k -> a
M.! Int
i]) | (Int
i, Box () Int
bx) <- [(Int, Box () Int)]
bxs, Int
n <- Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx]
    layersOf :: k -> Map k [a] -> [a]
layersOf k
n Map k [a]
m = [a] -> k -> Map k [a] -> [a]
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault [] k
n Map k [a]
m
    fb :: [Int]
fb = [Int
n | Int
n <- Shape -> [Int]
shapeNodes Shape
sh, [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
P.or [Int
mk Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.>= Int
u | Int
u <- Int -> Map Int [Int] -> [Int]
forall {k} {a}. Ord k => k -> Map k [a] -> [a]
layersOf Int
n Map Int [Int]
usedAt, Int
mk <- Int -> Map Int [Int] -> [Int]
forall {k} {a}. Ord k => k -> Map k [a] -> [a]
layersOf Int
n Map Int [Int]
madeAt]]
    key :: Int -> Key
key Int
n = if Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` [Int]
fb then Int -> Key
KL Int
n else Int -> Key
KN Int
n
    alive :: Int -> Key -> Bool
alive Int
t (KN Int
n)
      | Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` [Int]
fb = (Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.> Int
t) (Int -> Map Int [Int] -> [Int]
forall {k} {a}. Ord k => k -> Map k [a] -> [a]
layersOf Int
n Map Int [Int]
usedAt)
      | Bool
P.otherwise = (Int -> Bool) -> [Int] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.any (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.> Int
t) (Int -> Map Int [Int] -> [Int]
forall {k} {a}. Ord k => k -> Map k [a] -> [a]
layersOf Int
n Map Int [Int]
usedAt [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Int -> Map Int [Int] -> [Int]
forall {k} {a}. Ord k => k -> Map k [a] -> [a]
layersOf Int
n Map Int [Int]
madeAt) Bool -> Bool -> Bool
P.|| Int
n Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.elem` Shape -> [Int]
shapeOuts Shape
sh
    alive Int
_ (KL Int
_) = Bool
P.True

-- | The nodes attached to none of the given boxes and to no boundary: closed loops, spiders without
-- legs.
isolated :: Shape -> [Ix] -> [Key]
isolated :: Shape -> [(Int, Box () Int)] -> [Key]
isolated Shape
sh [(Int, Box () Int)]
bxs = [Int -> Key
KN Int
n | Int
n <- Shape -> [Int]
shapeNodes Shape
sh, Int
n Int -> Set Int -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Int
attached]
  where
    attached :: Set Int
attached = [Int] -> Set Int
forall a. Ord a => [a] -> Set a
Set.fromList (Shape -> [Int]
shapeIns Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Shape -> [Int]
shapeOuts Shape
sh [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ [[Int]] -> [Int]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
P.concat [Box () Int -> [Int]
forall l n. Box l n -> [n]
inputs Box () Int
bx [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
P.++ Box () Int -> [Int]
forall l n. Box l n -> [n]
outputs Box () Int
bx | (Int
_, Box () Int
bx) <- [(Int, Box () Int)]
bxs])

-- ** Building

-- | The term of a piece: a state with its own wires of one node merged and those nothing else needs
-- discarded, or two halves side by side with the nodes only they need merged away.
pieceArrow
  :: forall s
   . (SymMonoidal s, Supplies Frobenius s)
  => Align s -> (Key -> SomeSort s) -> M.Map P.Int (SomeArrow s) -> Tree -> SomeArrow s
pieceArrow :: forall s.
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> Map Int (SomeArrow s)
-> Tree
-> SomeArrow s
pieceArrow Align s
al Key -> SomeSort s
nodeSort Map Int (SomeArrow s)
arrows0 Tree
t0 = case Tree -> Built '[]
go Tree
t0 of
  Built Sorts ys
ys Step '[] ys
f -> Sorts '[] -> Sorts ys -> ('[] ~> ys) -> SomeArrow s
forall {s} (ys :: [s]) (bs :: [s]).
Sorts ys -> Sorts bs -> (ys ~> bs) -> SomeArrow s
SomeArrow Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Sorts ys
ys (Sorts '[] -> Step '[] ys -> '[] ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Step '[] ys
f)
  where
    go :: Tree -> Built ('[] :: [s])
    go :: Tree -> Built '[]
go Tree
t = Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built '[]
-> Built '[]
forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built xs
-> Built xs
transition Maybe (Step '[x] '[y])
Align s
al Key -> SomeSort s
nodeSort [] (Tree -> [Key]
treeMade Tree
t) (Tree -> [Key]
treeKeys Tree
t) (Tree -> Built '[]
body Tree
t)
    body :: Tree -> Built '[]
body (Leaf Int
i [Key]
_ [Key]
_) = Align s -> SomeArrow s -> Sorts '[] -> Built '[]
forall s (xs :: [s]).
Monoidal s =>
Align s -> SomeArrow s -> Sorts xs -> Built xs
boxThen Maybe (Step '[x] '[y])
Align s
al (Map Int (SomeArrow s)
arrows0 Map Int (SomeArrow s) -> Int -> SomeArrow s
forall k a. Ord k => Map k a -> k -> a
M.! Int
i) Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil
    body (Merge Tree
l Tree
r [Key]
_) = Sorts '[]
-> Built '[] -> Sorts '[] -> Built '[] -> Built ('[] ++ '[])
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil (Tree -> Built '[]
go Tree
l) Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil (Tree -> Built '[]
go Tree
r)

-- | What is built so far followed by one spider per wire kind, also for the given kinds without
-- wires, between permutations that group the wires. Each step is composed onto what is built so far
-- by itself, so that in a category of matrices a state is only ever multiplied by one step.
transition
  :: forall s (xs :: [s])
   . (SymMonoidal s, Supplies Frobenius s)
  => Align s -> (Key -> SomeSort s) -> [Key] -> [Key] -> [Key] -> Built xs -> Built xs
transition :: forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s
-> (Key -> SomeSort s)
-> [Key]
-> [Key]
-> [Key]
-> Built xs
-> Built xs
transition Align s
al Key -> SomeSort s
nodeSort [Key]
extra [Key]
from [Key]
to Built xs
built =
  let present :: [Key]
present = [Key] -> [Key]
forall a. Ord a => [a] -> [a]
nubOrd ([Key]
from [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
to)
      kinds :: [Key]
kinds = [Key] -> [Key] -> [Key] -> [Key]
groupOrder [Key]
from [Key]
to [Key]
present [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key
k | Key
k <- [Key]
extra, Key
k Key -> [Key] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`P.notElem` [Key]
present]
      count :: a -> [a] -> Int
count a
k [a]
ks = [a] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
P.filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
P.== a
k) [a]
ks)
      identity :: Bool
identity = (Key -> Bool) -> [Key] -> Bool
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Bool
P.all (\Key
k -> Key -> [Key] -> Int
forall {a}. Eq a => a -> [a] -> Int
count Key
k [Key]
from Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
1 Bool -> Bool -> Bool
P.&& Key -> [Key] -> Int
forall {a}. Eq a => a -> [a] -> Int
count Key
k [Key]
to Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
1) [Key]
kinds
      spiders :: forall (ws :: [s]). Sorts ws -> Built ws
      spiders :: forall (ws :: [s]). Sorts ws -> Built ws
spiders Sorts ws
ws
        | Bool
identity = Sorts ws -> Step ws ws -> Built ws
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts ws
ws Step ws ws
forall {s} (xs :: [s]). Step xs xs
Same
        | Bool
P.otherwise = Align s -> [(SomeSort s, Int, Int)] -> Sorts ws -> Built ws
forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s -> [(SomeSort s, Int, Int)] -> Sorts xs -> Built xs
spidersThen Maybe (Step '[x] '[y])
Align s
al [(Key -> SomeSort s
nodeSort Key
k, Key -> [Key] -> Int
forall {a}. Eq a => a -> [a] -> Int
count Key
k [Key]
from, Key -> [Key] -> Int
forall {a}. Eq a => a -> [a] -> Int
count Key
k [Key]
to) | Key
k <- [Key]
kinds] Sorts ws
ws
  in [Int] -> Built xs -> Built xs
forall s (xs :: [s]).
SymMonoidal s =>
[Int] -> Built xs -> Built xs
permuteThen ([Int] -> [Int]
forall {a}. Ord a => [a] -> [Int]
inverse ([Key] -> [Key] -> [Int]
positionsIn [Key]
kinds [Key]
to)) (Sorts ys -> Built ys
forall (ws :: [s]). Sorts ws -> Built ws
spiders (forall (ws :: [s]). Sorts ws -> Built ws) -> Built xs -> Built xs
forall {s} (xs :: [s]).
Monoidal s =>
(forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
`afterBuilt` [Int] -> Built xs -> Built xs
forall s (xs :: [s]).
SymMonoidal s =>
[Int] -> Built xs -> Built xs
permuteThen ([Key] -> [Key] -> [Int]
positionsIn [Key]
kinds [Key]
from) Built xs
built)
  where
    inverse :: [a] -> [Int]
inverse [a]
p = ((a, Int) -> Int) -> [(a, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (a, Int) -> Int
forall a b. (a, b) -> b
P.snd ([(a, Int)] -> [(a, Int)]
forall a. Ord a => [a] -> [a]
List.sort ([a] -> [Int] -> [(a, Int)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [a]
p [Int
0 :: P.Int ..]))

-- | The positions of the wires in the order that groups them by kind.
positionsIn :: [Key] -> [Key] -> [P.Int]
positionsIn :: [Key] -> [Key] -> [Int]
positionsIn [Key]
kinds [Key]
ks = [Int
i | Key
k <- [Key]
kinds, Int
i <- [Int
j | (Int
j, Key
k') <- [Int] -> [Key] -> [(Int, Key)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 :: P.Int ..] [Key]
ks, Key
k' Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
P.== Key
k]]

-- | The order of the kinds that needs the fewest swaps, each weighed by the number of wires it
-- crosses: every order for a few kinds, else by the average position of their wires. The swaps
-- between two kinds depend only on which of them goes first.
groupOrder :: [Key] -> [Key] -> [Key] -> [Key]
groupOrder :: [Key] -> [Key] -> [Key] -> [Key]
groupOrder [Key]
from [Key]
to [Key]
present
  | [Key] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Key]
present Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
P.<= Int
6 = ([Key] -> [Key] -> Ordering) -> [[Key]] -> [Key]
forall (t :: Type -> Type) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
List.minimumBy (([Key] -> Int) -> [Key] -> [Key] -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing [Key] -> Int
cost) ([Key] -> [[Key]]
forall a. [a] -> [[a]]
List.permutations [Key]
present)
  | Bool
P.otherwise = (Key -> Double) -> [Key] -> [Key]
forall b a. Ord b => (a -> b) -> [a] -> [a]
List.sortOn Key -> Double
average [Key]
present
  where
    crossings :: [b] -> Map (b, b) Int
crossings [b]
ks = (Int -> Int -> Int) -> [((b, b), Int)] -> Map (b, b) Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) [((b
a, b
b), Int
1 :: P.Int) | (Int
j, b
a) <- [Int] -> [b] -> [(Int, b)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 :: P.Int ..] [b]
ks, b
b <- Int -> [b] -> [b]
forall a. Int -> [a] -> [a]
P.take Int
j [b]
ks, b
a b -> b -> Bool
forall a. Eq a => a -> a -> Bool
P./= b
b]
    weighed :: Map (Key, Key) Int
weighed = (Int -> Int -> Int)
-> Map (Key, Key) Int -> Map (Key, Key) Int -> Map (Key, Key) Int
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(P.+) ((Int -> Int) -> Map (Key, Key) Int -> Map (Key, Key) Int
forall a b. (a -> b) -> Map (Key, Key) a -> Map (Key, Key) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
P.* [Key] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Key]
from) ([Key] -> Map (Key, Key) Int
forall {b}. Ord b => [b] -> Map (b, b) Int
crossings [Key]
from)) ((Int -> Int) -> Map (Key, Key) Int -> Map (Key, Key) Int
forall a b. (a -> b) -> Map (Key, Key) a -> Map (Key, Key) b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (Int -> Int -> Int
forall a. Num a => a -> a -> a
P.* [Key] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Key]
to) ([Key] -> Map (Key, Key) Int
forall {b}. Ord b => [b] -> Map (b, b) Int
crossings [Key]
to))
    -- each pair of kinds in the wrong order costs its wires that cross
    cost :: [Key] -> Int
cost [Key]
kinds = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
P.sum [Int -> (Key, Key) -> Map (Key, Key) Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
M.findWithDefault Int
0 (Key
a, Key
b) Map (Key, Key) Int
weighed | (Int
j, Key
b) <- [Int] -> [Key] -> [(Int, Key)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 :: P.Int ..] [Key]
kinds, Key
a <- Int -> [Key] -> [Key]
forall a. Int -> [a] -> [a]
P.take Int
j [Key]
kinds]
    average :: Key -> Double
average Key
k =
      let is :: [Int]
is = [Int
i | (Int
i, Key
k') <- [Int] -> [Key] -> [(Int, Key)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 :: P.Int ..] ([Key]
from [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ [Key]
to), Key
k' Key -> Key -> Bool
forall a. Eq a => a -> a -> Bool
P.== Key
k]
      in Int -> Double
forall a b. (Integral a, Num b) => a -> b
P.fromIntegral ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: Type -> Type) a. (Foldable t, Num a) => t a -> a
P.sum [Int]
is) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
P./ (Int -> Double
forall a b. (Integral a, Num b) => a -> b
P.fromIntegral ([Int] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [Int]
is) :: P.Double)

-- * Simplifying

-- | Open hypergraphs whose boxes are arrows of @k@: the category to run a term of a hypergraph
-- category in, with the arrows it uses made boxes by 'prim', to 'simplify' it.
type SIMPLIFY :: Kind -> Kind
type SIMPLIFY k = OPENHG k (Prim k)

-- | The label of a box of 'SIMPLIFY': the arrow the box was made from, whose sorts are those of the
-- box. Made only by 'prim', so 'simplify' can trust the sorts. Taking a label out of one hypergraph
-- and attaching it to other nodes with 'openHypergraph' breaks that trust.
type Prim :: Kind -> Type
newtype Prim k = Prim (SomeArrow k)

-- | An arrow of @k@ between lists of objects as one box.
prim
  :: forall {k} (as :: [k]) bs. (SortList as, SortList bs) => as ~> bs -> Wires as ~> (Wires bs :: SIMPLIFY k)
prim :: forall {k} (as :: [k]) (bs :: [k]).
(SortList as, SortList bs) =>
(as ~> bs) -> Wires as ~> Wires bs
prim as ~> bs
f = Prim k -> DC (SUB (FH (Port as))) ~> DC (SUB (FH (Port bs)))
forall {s} l (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
l -> Wires as ~> Wires bs
box (SomeArrow k -> Prim k
forall k. SomeArrow k -> Prim k
Prim ((as ~> bs) -> SomeArrow k
forall {s} (as :: [s]) (bs :: [s]).
(SortList as, SortList bs) =>
(as ~> bs) -> SomeArrow s
someArrow as ~> bs
f))

-- | An arrow from the tensor unit as a box with no inputs and one output.
prim0 :: forall {k} (a :: k). (Monoidal k) => Unit ~> a -> Wires '[] ~> (Wires '[a] :: SIMPLIFY k)
prim0 :: forall {k} (a :: k).
Monoidal k =>
(Unit ~> a) -> Wires '[] ~> Wires '[a]
prim0 f :: Unit ~> a
f@Unit ~> a
Objs = ('[] ~> '[a])
-> DC (SUB (FH (Port '[]))) ~> DC (SUB (FH (Port '[a])))
forall {k} (as :: [k]) (bs :: [k]).
(SortList as, SortList bs) =>
(as ~> bs) -> Wires as ~> Wires bs
prim ((Fold '[] ~> Fold '[a]) -> Strictified '[] '[a]
forall {k} (as :: [k]) (bs :: [k]).
(Ob as, Ob bs) =>
(Fold as ~> Fold bs) -> Strictified as bs
Str Unit ~> a
Fold '[] ~> Fold '[a]
f)

-- | An arrow as a box with one input and one output.
prim1 :: forall {k} (a :: k) b. (CategoryOf k) => a ~> b -> Wires '[a] ~> (Wires '[b] :: SIMPLIFY k)
prim1 :: forall {k} (a :: k) (b :: k).
CategoryOf k =>
(a ~> b) -> Wires '[a] ~> Wires '[b]
prim1 f :: a ~> b
f@a ~> b
Objs = ('[a] ~> '[b])
-> DC (SUB (FH (Port '[a]))) ~> DC (SUB (FH (Port '[b])))
forall {k} (as :: [k]) (bs :: [k]).
(SortList as, SortList bs) =>
(as ~> bs) -> Wires as ~> Wires bs
prim ((a ~> b) -> '[a] ~> '[b]
forall k (a :: k) (b :: k).
CategoryOf k =>
(a ~> b) -> '[a] ~> '[b]
singleton a ~> b
f)

-- | An arrow from a tensor as a box with two inputs and one output.
prim2
  :: forall {k} (a :: k) b c
   . (Monoidal k, Ob a, Ob b)
  => (a ** b ~> c) -> Wires '[a, b] ~> (Wires '[c] :: SIMPLIFY k)
prim2 :: forall {k} (a :: k) (b :: k) (c :: k).
(Monoidal k, Ob a, Ob b) =>
((a ** b) ~> c) -> Wires '[a, b] ~> Wires '[c]
prim2 f :: (a ** b) ~> c
f@(a ** b) ~> c
Objs = ('[a, b] ~> '[c])
-> DC (SUB (FH (Port '[a, b]))) ~> DC (SUB (FH (Port '[c])))
forall {k} (as :: [k]) (bs :: [k]).
(SortList as, SortList bs) =>
(as ~> bs) -> Wires as ~> Wires bs
prim ((Fold '[a, b] ~> Fold '[c]) -> Strictified '[a, b] '[c]
forall {k} (as :: [k]) (bs :: [k]).
(Ob as, Ob bs) =>
(Fold as ~> Fold bs) -> Strictified as bs
Str (a ** b) ~> c
Fold '[a, b] ~> Fold '[c]
f)

-- | An arrow from a left-associated tensor as a box with three inputs and one output.
-- Reassociates the right-associated port list to the arrow's input tensor.
prim3
  :: forall {k} (a :: k) b c d
   . (Monoidal k, Ob a, Ob b, Ob c)
  => (a ** b ** c ~> d) -> Wires '[a, b, c] ~> (Wires '[d] :: SIMPLIFY k)
prim3 :: forall {k} (a :: k) (b :: k) (c :: k) (d :: k).
(Monoidal k, Ob a, Ob b, Ob c) =>
(((a ** b) ** c) ~> d) -> Wires '[a, b, c] ~> Wires '[d]
prim3 f :: ((a ** b) ** c) ~> d
f@((a ** b) ** c) ~> d
Objs = ('[a, b, c] ~> '[d])
-> DC (SUB (FH (Port '[a, b, c]))) ~> DC (SUB (FH (Port '[d])))
forall {k} (as :: [k]) (bs :: [k]).
(SortList as, SortList bs) =>
(as ~> bs) -> Wires as ~> Wires bs
prim ((Fold '[a, b, c] ~> Fold '[d]) -> Strictified '[a, b, c] '[d]
forall {k} (as :: [k]) (bs :: [k]).
(Ob as, Ob bs) =>
(Fold as ~> Fold bs) -> Strictified as bs
Str (((a ** b) ** c) ~> d
f (((a ** b) ** c) ~> d)
-> ((a ** (b ** c)) ~> ((a ** b) ** c)) -> (a ** (b ** c)) ~> d
forall (b :: k) (c :: k) (a :: k). (b ~> c) -> (a ~> b) -> a ~> c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. forall k (a :: k) (b :: k) (c :: k).
(Monoidal k, Ob a, Ob b, Ob c) =>
(a ** (b ** c)) ~> ((a ** b) ** c)
associatorInv @k @a @b @c))

-- | An arrow as the label of a box with any sorts. Only for boxes whose sorts are equal to the
-- arrow's by construction, as for 'unsafeOpenHypergraph'.
unsafePrim :: SomeArrow k -> Prim k
unsafePrim :: forall k. SomeArrow k -> Prim k
unsafePrim = SomeArrow k -> Prim k
forall k. SomeArrow k -> Prim k
Prim

-- | Read a primitive graph using the given wiring. Primitive sorts are trusted, so
-- 'DecidableIso' is unnecessary: for example, @simplify copyDiscard graph@ can execute a graph
-- as a Haskell function.
simplify
  :: forall {k} a b
   . Wiring k
  -> (a :: SIMPLIFY k) ~> b
  -> P.Either P.String (WireSorts a ~> WireSorts b)
simplify :: forall {k} (a :: SIMPLIFY k) (b :: SIMPLIFY k).
Wiring k -> (a ~> b) -> Either String (WireSorts a ~> WireSorts b)
simplify Wiring k
wiring =
  Wiring k
-> forall l (a :: OPENHG k l) (b :: OPENHG k l).
   Align k
   -> Feedback k
   -> Scheduling
   -> (SomeSort k -> Int)
   -> (l -> SomeArrow k)
   -> (a ~> b)
   -> Either String (WireSorts a ~> WireSorts b)
forall s.
Wiring s
-> forall l (a :: OPENHG s l) (b :: OPENHG s l).
   Align s
   -> Feedback s
   -> Scheduling
   -> (SomeSort s -> Int)
   -> (l -> SomeArrow s)
   -> (a ~> b)
   -> Either String (WireSorts a ~> WireSorts b)
runWiring
    Wiring k
wiring
    Maybe (Step '[x] '[y])
Align k
forall s (x :: s) (y :: s). (Ob x, Ob y) => Maybe (Step '[x] '[y])
trusted
    (Wiring k -> Feedback k
forall s. Wiring s -> Feedback s
wiringFeedback Wiring k
wiring)
    (Wiring k -> Scheduling
forall s. Wiring s -> Scheduling
wiringScheduling Wiring k
wiring)
    ((SomeSort k -> Int)
-> Maybe (SomeSort k -> Int) -> SomeSort k -> Int
forall a. a -> Maybe a -> a
fromMaybe (Int -> SomeSort k -> Int
forall a b. a -> b -> a
P.const Int
1) (Wiring k -> Maybe (SomeSort k -> Int)
forall s. Wiring s -> Maybe (SomeSort s -> Int)
wiringSize Wiring k
wiring))
    (\(Prim SomeArrow k
arrow) -> SomeArrow k
arrow)

-- | Interpret a primitive graph in its hypergraph target, with wire sizes from 'Sized'.
-- This is 'simplify' with 'frobenius': every graph is supported and
-- primitive sorts are trusted, so the result needs no 'P.Either'.
simplifyHypergraph
  :: forall {k} a b
   . (Hypergraph k, Sized k)
  => (a :: SIMPLIFY k) ~> b
  -> WireSorts a ~> WireSorts b
simplifyHypergraph :: forall {k} (a :: SIMPLIFY k) (b :: SIMPLIFY k).
(Hypergraph k, Sized k) =>
(a ~> b) -> WireSorts a ~> WireSorts b
simplifyHypergraph = (String
 -> Strictified
      (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
-> (Strictified
      (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
    -> Strictified
         (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
-> Either
     String
     (Strictified
        (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
-> Strictified
     (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
P.either String
-> Strictified
     (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
forall a. HasCallStack => String -> a
P.error Strictified
  (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
-> Strictified
     (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
forall a. a -> a
P.id (Either
   String
   (Strictified
      (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
 -> Strictified
      (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b))))
-> (DecCospan a b
    -> Either
         String
         (Strictified
            (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))))
-> DecCospan a b
-> Strictified
     (PortSorts (UN SUB (UN DC a))) (PortSorts (UN SUB (UN DC b)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
P.. Wiring k
-> (a ~> b)
-> Either
     String
     (PortSorts (UN SUB (UN DC a)) ~> PortSorts (UN SUB (UN DC b)))
forall {k} (a :: SIMPLIFY k) (b :: SIMPLIFY k).
Wiring k -> (a ~> b) -> Either String (WireSorts a ~> WireSorts b)
simplify Wiring k
forall s. (Hypergraph s, Sized s) => Wiring s
frobenius

-- | 'simplifyHypergraph' with every box bent into a state on all its wires, its inputs turned into outputs
-- with cups. The read-back then contracts the whole network in the order of 'planContraction',
-- instead of following the flow from inputs to outputs, and needs no traces for cycles. For
-- computing with a term rather than drawing it, as the result is drawn with cups and caps.
simplifyFlat :: forall {k} a b. (Hypergraph k, Sized k) => (a :: SIMPLIFY k) ~> b -> WireSorts a ~> WireSorts b
simplifyFlat :: forall {k} (a :: SIMPLIFY k) (b :: SIMPLIFY k).
(Hypergraph k, Sized k) =>
(a ~> b) -> WireSorts a ~> WireSorts b
simplifyFlat (DecCospan a1 ~> c
l b1 ~> c
r (Boxes [Box (Prim k) n]
bxs)) =
  (DC a1 ~> DC b1) -> WireSorts (DC a1) ~> WireSorts (DC b1)
forall {k} (a :: SIMPLIFY k) (b :: SIMPLIFY k).
(Hypergraph k, Sized k) =>
(a ~> b) -> WireSorts a ~> WireSorts b
simplifyHypergraph ((a1 ~> SUB (FH n))
-> (b1 ~> SUB (FH n))
-> Boxes (Prim k) (SUB (FH n))
-> DecCospan (DC a1) (DC b1)
forall {k} {f :: k -> Type} (c :: k) (a1 :: k) (b1 :: k).
(a1 ~> c) -> (b1 ~> c) -> f c -> DecCospan (DC a1) (DC b1)
DecCospan a1 ~> c
a1 ~> SUB (FH n)
l b1 ~> c
b1 ~> SUB (FH n)
r ([Box (Prim k) n] -> Boxes (Prim k) (SUB (FH n))
forall {s} l ys. [Box l ys] -> Boxes l (SUB (FH ys))
Boxes ((Box (Prim k) n -> Box (Prim k) n)
-> [Box (Prim k) n] -> [Box (Prim k) n]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap Box (Prim k) n -> Box (Prim k) n
forall {k} {n}. Hypergraph k => Box (Prim k) n -> Box (Prim k) n
bent [Box (Prim k) n]
bxs)))
  where
    bent :: Box (Prim k) n -> Box (Prim k) n
bent bx :: Box (Prim k) n
bx@(Box (Prim (SomeArrow Sorts as
xs Sorts bs
ys as ~> bs
f)) [n]
is [n]
os)
      | [n] -> Bool
forall a. [a] -> Bool
forall (t :: Type -> Type) a. Foldable t => t a -> Bool
P.null [n]
is = Box (Prim k) n
bx
      | Bool
P.otherwise = Prim k -> [n] -> [n] -> Box (Prim k) n
forall l n. l -> [n] -> [n] -> Box l n
Box (SomeArrow k -> Prim k
forall k. SomeArrow k -> Prim k
Prim (Sorts as -> Sorts bs -> (as ~> bs) -> SomeArrow k
forall {s} (as :: [s]) (bs :: [s]).
Hypergraph s =>
Sorts as -> Sorts bs -> (as ~> bs) -> SomeArrow s
bendInputs Sorts as
xs Sorts bs
ys as ~> bs
f)) [] ([n] -> [n]
forall a. [a] -> [a]
P.reverse [n]
is [n] -> [n] -> [n]
forall a. [a] -> [a] -> [a]
P.++ [n]
os)

-- | An arrow with its inputs bent over to its outputs with cups, one at a time from the first, so
-- that the state's wires are the inputs in reverse order followed by the outputs.
bendInputs :: forall {s} (as :: [s]) bs. (Hypergraph s) => Sorts as -> Sorts bs -> as ~> bs -> SomeArrow s
bendInputs :: forall {s} (as :: [s]) (bs :: [s]).
Hypergraph s =>
Sorts as -> Sorts bs -> (as ~> bs) -> SomeArrow s
bendInputs ListOf SortOb as
Nil Sorts bs
ys as ~> bs
f = Sorts '[] -> Sorts bs -> ('[] ~> bs) -> SomeArrow s
forall {s} (ys :: [s]) (bs :: [s]).
Sorts ys -> Sorts bs -> (ys ~> bs) -> SomeArrow s
SomeArrow Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Sorts bs
ys as ~> bs
'[] ~> bs
f
bendInputs (Cons @x @rest ListOf SortOb xs1
xs) Sorts bs
ys as ~> bs
f =
  ListOf SortOb xs1 -> (IsList xs1 => SomeArrow s) -> SomeArrow s
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf ListOf SortOb xs1
xs ((IsList xs1 => SomeArrow s) -> SomeArrow s)
-> (IsList xs1 => SomeArrow s) -> SomeArrow s
forall a b. (a -> b) -> a -> b
P.$ ListOf SortOb xs1
-> Sorts (x : bs) -> (xs1 ~> (x : bs)) -> SomeArrow s
forall {s} (as :: [s]) (bs :: [s]).
Hypergraph s =>
Sorts as -> Sorts bs -> (as ~> bs) -> SomeArrow s
bendInputs ListOf SortOb xs1
xs (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x Sorts bs
ys) ((forall (a :: [s]). (CategoryOf [s], Ob a) => Obj a
forall {k} (a :: k). (CategoryOf k, Ob a) => Obj a
obj @'[x] Strictified '[x] '[x]
-> Strictified (x : xs1) bs
-> Strictified ('[x] ** (x : xs1)) ('[x] ** bs)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** as ~> bs
Strictified (x : xs1) bs
f) Strictified ('[x] ++ (x : xs1)) (x : bs)
-> Strictified xs1 ('[x] ++ (x : xs1)) -> Strictified xs1 (x : bs)
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. (forall (a2 :: s). Frobenius a2 => '[] ~> '[a2, a2]
forall {a1} (a2 :: a1). Frobenius a2 => '[] ~> '[a2, a2]
cupS @x Strictified '[] '[x, x]
-> Strictified xs1 xs1 -> Strictified ('[] ** xs1) ('[x, x] ** xs1)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** forall (a :: [s]). (CategoryOf [s], Ob a) => Obj a
forall {k} (a :: k). (CategoryOf k, Ob a) => Obj a
obj @rest))

-- | The size of a sort, from 'Sized'.
sizeFromSized :: forall s. (Sized s) => SomeSort s -> P.Int
sizeFromSized :: forall s. Sized s => SomeSort s -> Int
sizeFromSized (Some @x) = forall k (a :: k). (Sized k, Ob a) => Int
sizeOf @s @x

-- | A way to line up a wire of one sort with one of another: nothing to do when they are equal, an
-- arrow along their isomorphism otherwise, or nothing when they cannot be.
type Align :: Kind -> Type
type Align s = forall (x :: s) (y :: s). (Ob x, Ob y) => P.Maybe (Step '[x] '[y])

-- | Sorts lined up along an isomorphism found by 'DecidableIso'.
byIso :: forall s. (DecidableIso s) => Align s
byIso :: forall s. DecidableIso s => Align s
byIso @_ @x @y = (Optic Profunctor x x y y -> Step '[x] '[y])
-> Maybe (Optic Profunctor x x y y) -> Maybe (Step '[x] '[y])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
P.fmap (\Optic Profunctor x x y y
o -> forall {k} (c :: (k -> k -> Type) -> Constraint) (s :: k) (t :: k)
       (a :: k) (b :: k) r.
(CategoryOf k, (Ob a, Ob b) => c (Yo a (OP b))) =>
Optic c s t a b -> ((s ~> a) -> (b ~> t) -> r) -> r
forall (c :: (s -> s -> Type) -> Constraint) (s :: s) (t :: s)
       (a :: s) (b :: s) r.
(CategoryOf s, (Ob a, Ob b) => c (Yo a (OP b))) =>
Optic c s t a b -> ((s ~> a) -> (b ~> t) -> r) -> r
withIso @Profunctor Optic Profunctor x x y y
o \x ~> y
f y ~> x
_ -> ('[x] ~> '[y]) -> Step '[x] '[y]
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow ((x ~> y) -> '[x] ~> '[y]
forall k (a :: k) (b :: k).
CategoryOf k =>
(a ~> b) -> '[a] ~> '[b]
singleton x ~> y
f)) (forall k (c :: (k +-> k) -> Constraint) (a :: k) (b :: k).
(DecidableIso k, Ob a, Ob b) =>
Maybe (Optic c a a b b)
isoOf @s @Profunctor @x @y)

-- | Sorts taken to be equal, as they are when they come from the same arrow.
trusted :: forall s. Align s
trusted :: forall s (x :: s) (y :: s). (Ob x, Ob y) => Maybe (Step '[x] '[y])
trusted @_ @x @y = Step '[x] '[y] -> Maybe (Step '[x] '[y])
forall a. a -> Maybe a
P.Just (Step '[x] '[x] -> Step '[x] '[y]
forall a b. a -> b
unsafeCoerce (Step '[x] '[x]
forall {s} (xs :: [s]). Step xs xs
Same :: Step '[x] '[x]) :: Step '[x] '[y])

-- | The states contracted into one piece, as a tree of box numbers, each with the wires it ends in:
-- its open nodes, each once, in the order their wires come in. A leaf also has the wires of its box.
data Tree = Leaf P.Int [Key] [Key] | Merge Tree Tree [Key]
  deriving (Tree -> Tree -> Bool
(Tree -> Tree -> Bool) -> (Tree -> Tree -> Bool) -> Eq Tree
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
/= :: Tree -> Tree -> Bool
P.Eq)

treeKeys :: Tree -> [Key]
treeKeys :: Tree -> [Key]
treeKeys (Leaf Int
_ [Key]
_ [Key]
ks) = [Key]
ks
treeKeys (Merge Tree
_ Tree
_ [Key]
ks) = [Key]
ks

-- | The wires that come into the last step of a piece.
treeMade :: Tree -> [Key]
treeMade :: Tree -> [Key]
treeMade (Leaf Int
_ [Key]
made [Key]
_) = [Key]
made
treeMade (Merge Tree
l Tree
r [Key]
_) = Tree -> [Key]
treeKeys Tree
l [Key] -> [Key] -> [Key]
forall a. [a] -> [a] -> [a]
P.++ Tree -> [Key]
treeKeys Tree
r

-- | The wires of the read-back: a node, and the part of a node that cyclic boxes make, which is fed
-- back to the node.
data Key = KN P.Int | KL P.Int
  deriving (Key -> Key -> Bool
(Key -> Key -> Bool) -> (Key -> Key -> Bool) -> Eq Key
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Key -> Key -> Bool
== :: Key -> Key -> Bool
$c/= :: Key -> Key -> Bool
/= :: Key -> Key -> Bool
P.Eq, Eq Key
Eq Key =>
(Key -> Key -> Ordering)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Bool)
-> (Key -> Key -> Key)
-> (Key -> Key -> Key)
-> Ord Key
Key -> Key -> Bool
Key -> Key -> Ordering
Key -> Key -> Key
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 :: Key -> Key -> Ordering
compare :: Key -> Key -> Ordering
$c< :: Key -> Key -> Bool
< :: Key -> Key -> Bool
$c<= :: Key -> Key -> Bool
<= :: Key -> Key -> Bool
$c> :: Key -> Key -> Bool
> :: Key -> Key -> Bool
$c>= :: Key -> Key -> Bool
>= :: Key -> Key -> Bool
$cmax :: Key -> Key -> Key
max :: Key -> Key -> Key
$cmin :: Key -> Key -> Key
min :: Key -> Key -> Key
P.Ord)

keyNode :: Key -> P.Int
keyNode :: Key -> Int
keyNode (KN Int
n) = Int
n
keyNode (KL Int
n) = Int
n

-- | An arrow from @xs@ to sorts known at runtime, or none yet.
type Step :: forall s. [s] -> [s] -> Type
data Step xs ys where
  Same :: Step xs xs
  Arrow :: xs ~> ys -> Step xs ys

-- | What is built so far from @xs@: the sorts it ends in and how it gets there.
type Built :: forall s. [s] -> Type
data Built xs where
  Built :: Sorts ys -> Step xs ys -> Built xs

-- | The next piece, built from the sorts the previous one ends in.
afterBuilt :: forall {s} (xs :: [s]). (Monoidal s) => (forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
afterBuilt :: forall {s} (xs :: [s]).
Monoidal s =>
(forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
afterBuilt forall (ys :: [s]). Sorts ys -> Built ys
k (Built Sorts ys
ys Step xs ys
f) = case Sorts ys -> Built ys
forall (ys :: [s]). Sorts ys -> Built ys
k Sorts ys
ys of
  Built Sorts ys
zs Step ys ys
g -> Sorts ys -> Step xs ys -> Built xs
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts ys
zs (Step ys ys -> Step xs ys -> Step xs ys
forall {s} {b :: [s]} {ys :: [s]} {xs :: [s]}.
MonoidalProfunctor (~>) =>
Step b ys -> Step xs b -> Step xs ys
compose Step ys ys
g Step xs ys
f)
  where
    compose :: Step b ys -> Step xs b -> Step xs ys
compose Step b ys
Same Step xs b
h = Step xs ys
Step xs b
h
    compose Step b ys
h Step xs b
Same = Step xs ys
Step b ys
h
    compose (Arrow b ~> ys
q) (Arrow xs ~> b
p) = (xs ~> ys) -> Step xs ys
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (b ~> ys
Strictified b ys
q Strictified b ys -> Strictified xs b -> Strictified xs ys
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. xs ~> b
Strictified xs b
p)

arrowOf :: (Monoidal s) => Sorts (xs :: [s]) -> Step xs ys -> xs ~> ys
arrowOf :: forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts xs
xs Step xs ys
Same = Sorts xs -> (IsList xs => Strictified xs xs) -> Strictified xs xs
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf Sorts xs
xs Strictified xs xs
IsList xs => Strictified xs xs
forall (a :: [s]). Ob a => Strictified a a
forall {k} (p :: CAT k) (a :: k). (Promonad p, Ob a) => p a a
id
arrowOf Sorts xs
_ (Arrow xs ~> ys
f) = xs ~> ys
f

-- | Two built pieces side by side.
beside :: (Monoidal s) => Sorts (xs :: [s]) -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside :: forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts xs
xs (Built Sorts ys
ys Step xs ys
f) Sorts xs'
xs' (Built Sorts ys
ys' Step xs' ys
g) = Sorts (ys ++ ys)
-> Step (xs ++ xs') (ys ++ ys) -> Built (xs ++ xs')
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (Sorts ys -> Sorts ys -> Sorts (ys ++ ys)
forall {k} (c :: OB k) (as :: [k]) (bs :: [k]).
ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)
appendListOf Sorts ys
ys Sorts ys
ys') (Sorts xs
-> Step xs ys
-> Sorts xs'
-> Step xs' ys
-> Step (xs ++ xs') (ys ++ ys)
forall s (xs :: [s]) (ys :: [s]) (xs' :: [s]) (ys' :: [s]).
Monoidal s =>
Sorts xs
-> Step xs ys
-> Sorts xs'
-> Step xs' ys'
-> Step (xs ++ xs') (ys ++ ys')
besideStep Sorts xs
xs Step xs ys
f Sorts xs'
xs' Step xs' ys
g)

-- | Two steps side by side.
besideStep
  :: (Monoidal s) => Sorts (xs :: [s]) -> Step xs ys -> Sorts xs' -> Step xs' ys' -> Step (xs ++ xs') (ys ++ ys')
besideStep :: forall s (xs :: [s]) (ys :: [s]) (xs' :: [s]) (ys' :: [s]).
Monoidal s =>
Sorts xs
-> Step xs ys
-> Sorts xs'
-> Step xs' ys'
-> Step (xs ++ xs') (ys ++ ys')
besideStep Sorts xs
_ Step xs ys
Same Sorts xs'
_ Step xs' ys'
Same = Step (xs ++ xs') (xs ++ xs')
Step (xs ++ xs') (ys ++ ys')
forall {s} (xs :: [s]). Step xs xs
Same
besideStep Sorts xs
xs Step xs ys
f Sorts xs'
xs' Step xs' ys'
g = ((xs ++ xs') ~> (ys ++ ys')) -> Step (xs ++ xs') (ys ++ ys')
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (Sorts xs -> Step xs ys -> xs ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts xs
xs Step xs ys
f Strictified xs ys
-> Strictified xs' ys' -> Strictified (xs ** xs') (ys ** ys')
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** Sorts xs' -> Step xs' ys' -> xs' ~> ys'
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts xs'
xs' Step xs' ys'
g)

-- | The list split after its first @n@ sorts.
splitSorts :: P.Int -> Sorts xs -> (forall pre post. (xs ~ (pre ++ post)) => Sorts pre -> Sorts post -> r) -> r
splitSorts :: forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts Int
0 Sorts xs
xs forall (pre :: [s]) (post :: [s]).
(xs ~ (pre ++ post)) =>
Sorts pre -> Sorts post -> r
k = Sorts '[] -> Sorts xs -> r
forall (pre :: [s]) (post :: [s]).
(xs ~ (pre ++ post)) =>
Sorts pre -> Sorts post -> r
k Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Sorts xs
xs
splitSorts Int
n (Cons @x ListOf SortOb xs1
rest) forall (pre :: [s]) (post :: [s]).
(xs ~ (pre ++ post)) =>
Sorts pre -> Sorts post -> r
k = Int
-> ListOf SortOb xs1
-> (forall (pre :: [s]) (post :: [s]).
    (xs1 ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1) ListOf SortOb xs1
rest \Sorts pre
pre Sorts post
post -> Sorts (x : pre) -> Sorts post -> r
forall (pre :: [s]) (post :: [s]).
(xs ~ (pre ++ post)) =>
Sorts pre -> Sorts post -> r
k (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x Sorts pre
pre) Sorts post
post
splitSorts Int
_ Sorts xs
Nil forall (pre :: [s]) (post :: [s]).
(xs ~ (pre ++ post)) =>
Sorts pre -> Sorts post -> r
_ = String -> r
forall a. HasCallStack => String -> a
P.error String
"readBack: a split beyond the wires was planned"

-- | Whether two sorts can be lined up.
lineUp :: forall s. Align s -> SomeSort s -> SomeSort s -> P.Bool
lineUp :: forall s. Align s -> SomeSort s -> SomeSort s -> Bool
lineUp Align s
al (Some @x) (Some @y) = Maybe (Step '[x] '[x]) -> Bool
forall a. Maybe a -> Bool
isJust (Align s
al @x @y)

-- | Whether two lists of sorts can be lined up, one by one.
lineUpAll :: forall s. Align s -> [SomeSort s] -> [SomeSort s] -> P.Bool
lineUpAll :: forall s. Align s -> [SomeSort s] -> [SomeSort s] -> Bool
lineUpAll Align s
al [SomeSort s]
xs [SomeSort s]
ys = [SomeSort s] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [SomeSort s]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== [SomeSort s] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
P.length [SomeSort s]
ys Bool -> Bool -> Bool
P.&& [Bool] -> Bool
forall (t :: Type -> Type). Foldable t => t Bool -> Bool
P.and ((SomeSort s -> SomeSort s -> Bool)
-> [SomeSort s] -> [SomeSort s] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
P.zipWith (Align s -> SomeSort s -> SomeSort s -> Bool
forall s. Align s -> SomeSort s -> SomeSort s -> Bool
lineUp Maybe (Step '[x] '[y])
Align s
al) [SomeSort s]
xs [SomeSort s]
ys)

-- | Wires of the first sorts lined up with the second, one at a time.
alignSteps :: (Monoidal s) => Align s -> Sorts (xs :: [s]) -> Sorts ys -> P.Maybe (Step xs ys)
alignSteps :: forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Align s -> Sorts xs -> Sorts ys -> Maybe (Step xs ys)
alignSteps Align s
_ ListOf SortOb xs
Nil ListOf SortOb ys
Nil = Step xs ys -> Maybe (Step xs ys)
forall a. a -> Maybe a
P.Just Step xs xs
Step xs ys
forall {s} (xs :: [s]). Step xs xs
Same
alignSteps Align s
al (Cons @x ListOf SortOb xs1
xs) (Cons @y ListOf SortOb xs1
ys) = do
  a <- Align s
al @x @y
  rest <- alignSteps al xs ys
  P.pure (besideStep (single @x) a xs rest)
alignSteps Align s
_ ListOf SortOb xs
_ ListOf SortOb ys
_ = Maybe (Step xs ys)
forall a. Maybe a
P.Nothing

single :: forall {s} (x :: s). (Ob' x) => Sorts '[x]
single :: forall {s} (x :: s). Ob' x => Sorts '[x]
single = forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x ListOf SortOb '[]
forall {k} (c :: OB k). ListOf c '[]
Nil

-- | Leave the first wires unchanged while building a step on the rest.
carryThen
  :: forall {s} (xs :: [s])
   . (Monoidal s)
  => P.Int
  -> (forall (ys :: [s]). Sorts ys -> Built ys)
  -> Sorts xs
  -> Built xs
carryThen :: forall {s} (xs :: [s]).
Monoidal s =>
Int
-> (forall (ys :: [s]). Sorts ys -> Built ys)
-> Sorts xs
-> Built xs
carryThen Int
n forall (ys :: [s]). Sorts ys -> Built ys
build Sorts xs
xs = Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> Built xs)
-> Built xs
forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts Int
n Sorts xs
xs \Sorts pre
pre Sorts post
post -> Sorts pre
-> Built pre -> Sorts post -> Built post -> Built (pre ++ post)
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts pre
pre (Sorts pre -> Step pre pre -> Built pre
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts pre
pre Step pre pre
forall {s} (xs :: [s]). Step xs xs
Same) Sorts post
post (Sorts post -> Built post
forall (ys :: [s]). Sorts ys -> Built ys
build Sorts post
post)

-- | The box on the first wires, and the rest of the wires unchanged.
boxThen :: (Monoidal s) => Align s -> SomeArrow s -> Sorts (xs :: [s]) -> Built xs
boxThen :: forall s (xs :: [s]).
Monoidal s =>
Align s -> SomeArrow s -> Sorts xs -> Built xs
boxThen Align s
al (SomeArrow Sorts as
as Sorts bs
bs as ~> bs
f) Sorts xs
xs = Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> Built xs)
-> Built xs
forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts (Sorts as -> Int
forall {k} (c :: OB k) (xs :: [k]). ListOf c xs -> Int
lengthListOf Sorts as
as) Sorts xs
xs \Sorts pre
pre Sorts post
post -> case Align s -> Sorts pre -> Sorts as -> Maybe (Step pre as)
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Align s -> Sorts xs -> Sorts ys -> Maybe (Step xs ys)
alignSteps Maybe (Step '[x] '[y])
Align s
al Sorts pre
pre Sorts as
as of
  P.Just Step pre as
into -> Sorts pre
-> Built pre -> Sorts post -> Built post -> Built (pre ++ post)
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts pre
pre (Sorts bs -> Step pre bs -> Built pre
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts bs
bs ((pre ~> bs) -> Step pre bs
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (as ~> bs
Strictified as bs
f Strictified as bs -> Strictified pre as -> Strictified pre bs
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. Sorts pre -> Step pre as -> pre ~> as
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf Sorts pre
pre Step pre as
into))) Sorts post
post (Sorts post -> Step post post -> Built post
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts post
post Step post post
forall {s} (xs :: [s]). Step xs xs
Same)
  Maybe (Step pre as)
P.Nothing -> String -> Built xs
forall a. HasCallStack => String -> a
P.error String
"readBack: a box was planned on wires of other sorts"

-- | What is built so far followed by its wires in the order that @p@ lists them, as adjacent swaps
-- composed one at a time: the wire at position @j@ of the result is wire @p !! j@ before.
permuteThen :: (SymMonoidal s) => [P.Int] -> Built (xs :: [s]) -> Built xs
permuteThen :: forall s (xs :: [s]).
SymMonoidal s =>
[Int] -> Built xs -> Built xs
permuteThen [Int]
p Built xs
built0 = (Built xs -> Int -> Built xs) -> Built xs -> [Int] -> Built xs
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (\Built xs
built Int
i -> Int -> Sorts ys -> Built ys
forall s (xs :: [s]). SymMonoidal s => Int -> Sorts xs -> Built xs
swapThen Int
i (forall {ys :: [s]}. Sorts ys -> Built ys) -> Built xs -> Built xs
forall {s} (xs :: [s]).
Monoidal s =>
(forall (ys :: [s]). Sorts ys -> Built ys) -> Built xs -> Built xs
`afterBuilt` Built xs
built) Built xs
built0 ([Int] -> [Int]
forall a. [a] -> [a]
P.reverse ([Int] -> [Int] -> [Int]
forall {a}. Ord a => [a] -> [Int] -> [Int]
bubble [Int]
p []))
  where
    -- the positions of the adjacent swaps that sort @p@
    bubble :: [a] -> [Int] -> [Int]
bubble [a]
ps [Int]
acc = case [Int
i | (Int
i, (a
a, a
b)) <- [Int] -> [(a, a)] -> [(Int, (a, a))]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [Int
0 ..] ([a] -> [a] -> [(a, a)]
forall a b. [a] -> [b] -> [(a, b)]
P.zip [a]
ps (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
P.drop Int
1 [a]
ps)), a
a a -> a -> Bool
forall a. Ord a => a -> a -> Bool
P.> a
b] of
      [] -> [Int] -> [Int]
forall a. [a] -> [a]
P.reverse [Int]
acc
      Int
i : [Int]
_ -> [a] -> [Int] -> [Int]
bubble (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
P.take Int
i [a]
ps [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
P.++ [[a]
ps [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
P.!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
1), [a]
ps [a] -> Int -> a
forall a. HasCallStack => [a] -> Int -> a
P.!! Int
i] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
P.++ Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
P.drop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
P.+ Int
2) [a]
ps) (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
acc)

-- | The swap of the wires at positions @i@ and @i + 1@.
swapThen :: (SymMonoidal s) => P.Int -> Sorts (xs :: [s]) -> Built xs
swapThen :: forall s (xs :: [s]). SymMonoidal s => Int -> Sorts xs -> Built xs
swapThen Int
0 (Cons @x (Cons @y ListOf SortOb xs1
rest)) = Sorts (x : x : xs1) -> Step xs (x : x : xs1) -> Built xs
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @y (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x ListOf SortOb xs1
rest)) ((xs ~> (x : x : xs1)) -> Step xs (x : x : xs1)
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (forall (a :: s) (b :: s).
(SymMonoidal s, Ob a, Ob b) =>
'[a, b] ~> '[b, a]
forall {k} (a :: k) (b :: k).
(SymMonoidal k, Ob a, Ob b) =>
'[a, b] ~> '[b, a]
swap2 @x @y Strictified '[x, x] '[x, x]
-> Strictified xs1 xs1
-> Strictified ('[x, x] ** xs1) ('[x, x] ** xs1)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** ListOf SortOb xs1
-> (IsList xs1 => Strictified xs1 xs1) -> Strictified xs1 xs1
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf ListOf SortOb xs1
rest Strictified xs1 xs1
IsList xs1 => Strictified xs1 xs1
forall (a :: [s]). Ob a => Strictified a a
forall {k} (p :: CAT k) (a :: k). (Promonad p, Ob a) => p a a
id))
swapThen Int
i (Cons @x ListOf SortOb xs1
rest) = case Int -> ListOf SortOb xs1 -> Built xs1
forall s (xs :: [s]). SymMonoidal s => Int -> Sorts xs -> Built xs
swapThen (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1) ListOf SortOb xs1
rest of
  Built Sorts ys
ys Step xs1 ys
f -> Sorts (x : ys) -> Step xs (x : ys) -> Built xs
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x Sorts ys
ys) ((xs ~> (x : ys)) -> Step xs (x : ys)
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (forall (a :: s). (Monoidal s, Ob a) => Obj '[a]
forall {k} (a :: k). (Monoidal k, Ob a) => Obj '[a]
obj1 @x Strictified '[x] '[x]
-> Strictified xs1 ys -> Strictified ('[x] ** xs1) ('[x] ** ys)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** ListOf SortOb xs1 -> Step xs1 ys -> xs1 ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf ListOf SortOb xs1
rest Step xs1 ys
f))
swapThen Int
_ ListOf SortOb xs
Nil = String -> Built xs
forall a. HasCallStack => String -> a
P.error String
"readBack: a swap beyond the wires was planned"

-- | For each sort, a spider from the given number of wires to the given number.
spidersThen
  :: (SymMonoidal s, Supplies Frobenius s) => Align s -> [(SomeSort s, P.Int, P.Int)] -> Sorts (xs :: [s]) -> Built xs
spidersThen :: forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s -> [(SomeSort s, Int, Int)] -> Sorts xs -> Built xs
spidersThen Align s
_ [] ListOf SortOb xs
Nil = Sorts '[] -> Step xs '[] -> Built xs
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil Step xs xs
Step xs '[]
forall {s} (xs :: [s]). Step xs xs
Same
spidersThen Align s
_ [] ListOf SortOb xs
_ = String -> Built xs
forall a. HasCallStack => String -> a
P.error String
"readBack: wires without a spider were planned"
spidersThen Align s
al ((SomeSort s
x, Int
c, Int
m) : [(SomeSort s, Int, Int)]
rest) ListOf SortOb xs
xs = Int
-> ListOf SortOb xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> Built xs)
-> Built xs
forall {s} (xs :: [s]) r.
Int
-> Sorts xs
-> (forall (pre :: [s]) (post :: [s]).
    (xs ~ (pre ++ post)) =>
    Sorts pre -> Sorts post -> r)
-> r
splitSorts Int
c ListOf SortOb xs
xs \Sorts pre
pre Sorts post
post -> Sorts pre
-> Built pre -> Sorts post -> Built post -> Built (pre ++ post)
forall s (xs :: [s]) (xs' :: [s]).
Monoidal s =>
Sorts xs -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')
beside Sorts pre
pre (Align s -> SomeSort s -> Int -> Int -> Sorts pre -> Built pre
forall s (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s -> SomeSort s -> Int -> Int -> Sorts pre -> Built pre
spider Maybe (Step '[x] '[y])
Align s
al SomeSort s
x Int
c Int
m Sorts pre
pre) Sorts post
post (Align s -> [(SomeSort s, Int, Int)] -> Sorts post -> Built post
forall s (xs :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s -> [(SomeSort s, Int, Int)] -> Sorts xs -> Built xs
spidersThen Maybe (Step '[x] '[y])
Align s
al [(SomeSort s, Int, Int)]
rest Sorts post
post)

-- | The spider of a sort from @c@ wires to @m@: merging all of them, then copying the result.
spider
  :: (SymMonoidal s, Supplies Frobenius s) => Align s -> SomeSort s -> P.Int -> P.Int -> Sorts (pre :: [s]) -> Built pre
spider :: forall s (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s) =>
Align s -> SomeSort s -> Int -> Int -> Sorts pre -> Built pre
spider Align s
al (Some @x) Int
c Int
m Sorts pre
pre
  | Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
1 Bool -> Bool -> Bool
P.&& Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
P.== Int
1 = Sorts pre -> Step pre pre -> Built pre
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts pre
pre Step pre pre
forall {s} (xs :: [s]). Step xs xs
Same
  | Bool
P.otherwise = case forall (x :: s). CocommutativeComonoid x => Int -> Built '[x]
forall {s} (x :: s). CocommutativeComonoid x => Int -> Built '[x]
copies @x Int
m of Built Sorts ys
ys Step '[x] ys
f -> Sorts ys -> Step pre ys -> Built pre
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts ys
ys ((pre ~> ys) -> Step pre ys
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (Sorts '[x] -> Step '[x] ys -> '[x] ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @x) Step '[x] ys
f Strictified '[x] ys -> Strictified pre '[x] -> Strictified pre ys
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. forall (x :: s) (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s, Ob x) =>
Align s -> Sorts pre -> pre ~> '[x]
forall {s} (x :: s) (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s, Ob x) =>
Align s -> Sorts pre -> pre ~> '[x]
merges @x Maybe (Step '[x] '[y])
Align s
al Sorts pre
pre))

-- | All the wires merged into one of sort @x@, each lined up with it first, or the unit of @x@ when
-- there are none.
merges :: forall {s} (x :: s) pre. (SymMonoidal s, Supplies Frobenius s, Ob x) => Align s -> Sorts pre -> pre ~> '[x]
merges :: forall {s} (x :: s) (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s, Ob x) =>
Align s -> Sorts pre -> pre ~> '[x]
merges Align s
_ ListOf SortOb pre
Nil = forall (m :: s). Monoid m => '[] ~> '[m]
forall {a} (m :: a). Monoid m => '[] ~> '[m]
memptyS @x
merges Align s
al (Cons @y ListOf SortOb xs1
Nil) = forall (y :: s) (x :: s).
(Monoidal s, Ob x, Ob y) =>
Align s -> '[y] ~> '[x]
forall {s} (y :: s) (x :: s).
(Monoidal s, Ob x, Ob y) =>
Align s -> '[y] ~> '[x]
toX @y Maybe (Step '[x] '[y])
Align s
al
merges Align s
al (Cons @y rest :: ListOf SortOb xs1
rest@Cons{}) = forall (m :: s). Monoid m => '[m, m] ~> '[m]
forall {k} (m :: k). Monoid m => '[m, m] ~> '[m]
mappendS @x Strictified '[x, x] '[x]
-> Strictified (x : x : xs1) '[x, x]
-> Strictified (x : x : xs1) '[x]
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. (forall (y :: s) (x :: s).
(Monoidal s, Ob x, Ob y) =>
Align s -> '[y] ~> '[x]
forall {s} (y :: s) (x :: s).
(Monoidal s, Ob x, Ob y) =>
Align s -> '[y] ~> '[x]
toX @y Maybe (Step '[x] '[y])
Align s
al Strictified '[x] '[x]
-> Strictified (x : xs1) '[x]
-> Strictified ('[x] ** (x : xs1)) ('[x] ** '[x])
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** forall (x :: s) (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s, Ob x) =>
Align s -> Sorts pre -> pre ~> '[x]
forall {s} (x :: s) (pre :: [s]).
(SymMonoidal s, Supplies Frobenius s, Ob x) =>
Align s -> Sorts pre -> pre ~> '[x]
merges @x Maybe (Step '[x] '[y])
Align s
al ListOf SortOb xs1
rest)

toX :: forall {s} y (x :: s). (Monoidal s, Ob x, Ob y) => Align s -> '[y] ~> '[x]
toX :: forall {s} (y :: s) (x :: s).
(Monoidal s, Ob x, Ob y) =>
Align s -> '[y] ~> '[x]
toX Align s
al = case Align s
al @y @x of
  P.Just Step '[y] '[x]
a -> Sorts '[y] -> Step '[y] '[x] -> '[y] ~> '[x]
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @y) Step '[y] '[x]
a
  Maybe (Step '[y] '[x])
P.Nothing -> String -> Strictified '[y] '[x]
forall a. HasCallStack => String -> a
P.error String
"readBack: a spider was planned on wires of other sorts"

-- | One wire of sort @x@ copied to @m@, or discarded when @m@ is 0.
copies :: forall {s} (x :: s). (CocommutativeComonoid x) => P.Int -> Built '[x]
copies :: forall {s} (x :: s). CocommutativeComonoid x => Int -> Built '[x]
copies Int
0 = Sorts '[] -> Step '[x] '[] -> Built '[x]
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built Sorts '[]
forall {k} (c :: OB k). ListOf c '[]
Nil (('[x] ~> '[]) -> Step '[x] '[]
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (forall (c :: s). Comonoid c => '[c] ~> '[]
forall {k} (c :: k). Comonoid c => '[c] ~> '[]
counitS @x))
copies Int
1 = Sorts '[x] -> Step '[x] '[x] -> Built '[x]
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @x) Step '[x] '[x]
forall {s} (xs :: [s]). Step xs xs
Same
copies Int
2 = Sorts '[x, x] -> Step '[x] '[x, x] -> Built '[x]
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @x)) (('[x] ~> '[x, x]) -> Step '[x] '[x, x]
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow (forall (c :: s). Comonoid c => '[c] ~> '[c, c]
forall {k} (c :: k). Comonoid c => '[c] ~> '[c, c]
comultS @x))
copies Int
m = case forall (x :: s). CocommutativeComonoid x => Int -> Built '[x]
forall {s} (x :: s). CocommutativeComonoid x => Int -> Built '[x]
copies @x (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
P.- Int
1) of
  Built Sorts ys
ys Step '[x] ys
f -> Sorts (x : ys) -> Step '[x] (x : ys) -> Built '[x]
forall {s} (ys :: [s]) (xs :: [s]).
Sorts ys -> Step xs ys -> Built xs
Built (forall (x :: s) (xs1 :: [s]).
SortOb x =>
ListOf SortOb xs1 -> ListOf SortOb (x : xs1)
forall {k} {c :: OB k} (x :: k) (xs1 :: [k]).
c x =>
ListOf c xs1 -> ListOf c (x : xs1)
Cons @x Sorts ys
ys) (('[x] ~> (x : ys)) -> Step '[x] (x : ys)
forall {s} (xs :: [s]) (ys :: [s]). (xs ~> ys) -> Step xs ys
Arrow ((forall (a :: s). (Monoidal s, Ob a) => Obj '[a]
forall {k} (a :: k). (Monoidal k, Ob a) => Obj '[a]
obj1 @x Strictified '[x] '[x]
-> Strictified '[x] ys -> Strictified ('[x] ** '[x]) ('[x] ** ys)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** Sorts '[x] -> Step '[x] ys -> '[x] ~> ys
forall s (xs :: [s]) (ys :: [s]).
Monoidal s =>
Sorts xs -> Step xs ys -> xs ~> ys
arrowOf (forall (x :: s). Ob' x => Sorts '[x]
forall {s} (x :: s). Ob' x => Sorts '[x]
single @x) Step '[x] ys
f) Strictified ('[x] ++ '[x]) (x : ys)
-> Strictified '[x] ('[x] ++ '[x]) -> Strictified '[x] (x : ys)
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. forall (c :: s). Comonoid c => '[c] ~> '[c, c]
forall {k} (c :: k). Comonoid c => '[c] ~> '[c, c]
comultS @x))

-- | The trace over the first wires, @us@, which feeds their outputs back to their inputs.
traceSorts
  :: forall {s} (us :: [s]) xs ys
   . (SymMonoidal s)
  => (forall (u :: s) x y. (Ob u, Ob x, Ob y) => u ** x ~> u ** y -> x ~> y)
  -> Sorts us
  -> Sorts xs
  -> Sorts ys
  -> (us ++ xs) ~> (us ++ ys)
  -> xs ~> ys
traceSorts :: forall {s} (us :: [s]) (xs :: [s]) (ys :: [s]).
SymMonoidal s =>
(forall (u :: s) (x :: s) (y :: s).
 (Ob u, Ob x, Ob y) =>
 ((u ** x) ~> (u ** y)) -> x ~> y)
-> Sorts us
-> Sorts xs
-> Sorts ys
-> ((us ++ xs) ~> (us ++ ys))
-> xs ~> ys
traceSorts forall (u :: s) (x :: s) (y :: s).
(Ob u, Ob x, Ob y) =>
((u ** x) ~> (u ** y)) -> x ~> y
_ ListOf SortOb us
Nil Sorts xs
_ Sorts ys
_ (us ++ xs) ~> (us ++ ys)
f = xs ~> ys
(us ++ xs) ~> (us ++ ys)
f
traceSorts forall (u :: s) (x :: s) (y :: s).
(Ob u, Ob x, Ob y) =>
((u ** x) ~> (u ** y)) -> x ~> y
close ListOf SortOb us
us Sorts xs
xs Sorts ys
ys (us ++ xs) ~> (us ++ ys)
f =
  ListOf SortOb us -> (IsList us => xs ~> ys) -> xs ~> ys
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf ListOf SortOb us
us ((IsList us => xs ~> ys) -> xs ~> ys)
-> (IsList us => xs ~> ys) -> xs ~> ys
forall a b. (a -> b) -> a -> b
P.$
    Sorts xs -> (IsList xs => xs ~> ys) -> xs ~> ys
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf Sorts xs
xs ((IsList xs => xs ~> ys) -> xs ~> ys)
-> (IsList xs => xs ~> ys) -> xs ~> ys
forall a b. (a -> b) -> a -> b
P.$
      Sorts ys -> (IsList ys => xs ~> ys) -> xs ~> ys
forall {k} (c :: k -> Constraint) (as :: [k]) r.
(CategoryOf k, forall (x :: k). c x => Ob' x) =>
ListOf c as -> (IsList as => r) -> r
withIsListOf Sorts ys
ys ((IsList ys => xs ~> ys) -> xs ~> ys)
-> (IsList ys => xs ~> ys) -> xs ~> ys
forall a b. (a -> b) -> a -> b
P.$
        case (forall (as :: [s]). (Ob as, Monoidal s) => '[Fold as] ~> as
forall {k} (as :: [k]). (Ob as, Monoidal k) => '[Fold as] ~> as
splitMany @us, forall (as :: [s]). (Ob as, Monoidal s) => '[Fold as] ~> as
forall {k} (as :: [k]). (Ob as, Monoidal k) => '[Fold as] ~> as
splitMany @xs, forall (as :: [s]). (Ob as, Monoidal s) => as ~> '[Fold as]
forall {k} (as :: [k]). (Ob as, Monoidal k) => as ~> '[Fold as]
concatMany @ys) of
          (splitUs :: Strictified '[Fold us] us
splitUs@Strictified '[Fold us] us
Objs, splitXs :: Strictified '[Fold xs] xs
splitXs@Strictified '[Fold xs] xs
Objs, concatYs :: Strictified ys '[Fold ys]
concatYs@Strictified ys '[Fold ys]
Objs) ->
            forall (as :: [s]). (Ob as, Monoidal s) => '[Fold as] ~> as
forall {k} (as :: [k]). (Ob as, Monoidal k) => '[Fold as] ~> as
splitMany @ys
              Strictified '[Fold ys] ys
-> Strictified xs '[Fold ys] -> Strictified xs ys
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. (Fold '[Fold xs] ~> Fold '[Fold ys])
-> Strictified '[Fold xs] '[Fold ys]
forall {k} (as :: [k]) (bs :: [k]).
(Ob as, Ob bs) =>
(Fold as ~> Fold bs) -> Strictified as bs
Str
                ( forall (u :: s) (x :: s) (y :: s).
(Ob u, Ob x, Ob y) =>
((u ** x) ~> (u ** y)) -> x ~> y
close @(Fold us) @(Fold xs) @(Fold ys)
                    (Strictified ('[Fold us] ++ '[Fold xs]) ('[Fold us] ++ '[Fold ys])
-> Fold ('[Fold us] ++ '[Fold xs])
   ~> Fold ('[Fold us] ++ '[Fold ys])
forall {k} (as :: [k]) (bs :: [k]).
Strictified as bs -> Fold as ~> Fold bs
unStr ((forall (as :: [s]). (Ob as, Monoidal s) => as ~> '[Fold as]
forall {k} (as :: [k]). (Ob as, Monoidal k) => as ~> '[Fold as]
concatMany @us Strictified us '[Fold us]
-> Strictified ys '[Fold ys]
-> Strictified (us ** ys) ('[Fold us] ** '[Fold ys])
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** Strictified ys '[Fold ys]
concatYs) Strictified (us ++ ys) ('[Fold us] ++ '[Fold ys])
-> Strictified ('[Fold us] ++ '[Fold xs]) (us ++ ys)
-> Strictified
     ('[Fold us] ++ '[Fold xs]) ('[Fold us] ++ '[Fold ys])
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. (us ++ xs) ~> (us ++ ys)
Strictified (us ++ xs) (us ++ ys)
f Strictified (us ++ xs) (us ++ ys)
-> Strictified ('[Fold us] ++ '[Fold xs]) (us ++ xs)
-> Strictified ('[Fold us] ++ '[Fold xs]) (us ++ ys)
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. (Strictified '[Fold us] us
splitUs Strictified '[Fold us] us
-> Strictified '[Fold xs] xs
-> Strictified ('[Fold us] ** '[Fold xs]) (us ** xs)
forall (x1 :: [s]) (x2 :: [s]) (y1 :: [s]) (y2 :: [s]).
Strictified x1 x2
-> Strictified y1 y2 -> Strictified (x1 ** y1) (x2 ** y2)
forall {j} {k} (p :: j +-> k) (x1 :: k) (x2 :: j) (y1 :: k)
       (y2 :: j).
MonoidalProfunctor p =>
p x1 x2 -> p y1 y2 -> p (x1 ** y1) (x2 ** y2)
** Strictified '[Fold xs] xs
splitXs)))
                )
              Strictified '[Fold xs] '[Fold ys]
-> Strictified xs '[Fold xs] -> Strictified xs '[Fold ys]
forall (b :: [s]) (c :: [s]) (a :: [s]).
Strictified b c -> Strictified a b -> Strictified a c
forall {k} (p :: CAT k) (b :: k) (c :: k) (a :: k).
Promonad p =>
p b c -> p a b -> p a c
. forall (as :: [s]). (Ob as, Monoidal s) => as ~> '[Fold as]
forall {k} (as :: [k]). (Ob as, Monoidal k) => as ~> '[Fold as]
concatMany @xs