packages feed

proarrow 0.2.0.0 → 0.3.0.0

raw patch · 79 files changed

+6004/−1926 lines, 79 filesdep +vector

Dependencies added: vector

Files

CHANGELOG.md view
@@ -1,5 +1,59 @@ # Revision history for proarrow +## 0.3.0.0 -- 2026-10-10++* `Proarrow.Tools.Einsum`: `einsum @"ij,jk->ik" a b` on tensors in hypergraph categories.+* `Proarrow.Tools.SMC`: index notation for categories whose index types are `Frobenius`: `sumOver`+  binds a summed index, `delta` is the Kronecker delta, and `*^`/`^*` multiply by a scalar term.+* `Proarrow.Tools.SMC` no longer uses linear types: a variable used more than once is copied+  (`CocommutativeComonoid`) and an unused one is discarded (`Comonoid`). `with` takes two terms and+  `caseOf` the scrutinee and two branches, sharing the variables around them. `call` and `closed`+  are removed.+* `Proarrow.Tools.SMC` is split into multiple internal modules.+* `Proarrow.Category.Instance.DecoratedCospan`: `DECCOSPAN f`, cospans whose apex carries an+  `Alternative` decoration, a hypergraph category.+* `Proarrow.Category.Instance.Cospan`: `COSPAN k` is `DECCOSPAN` with the `Undecorated` decoration.+* `Proarrow.Category.Instance.OpenHypergraph`: open hypergraphs with typed wires.+* `Proarrow.Category.Monoidal.Hypergraph`: `Sized`, the size of an object (a dimension, a number of+  elements), which the read-back of open hypergraphs and `einsum` choose their contraction order by.+* `Proarrow.Category.Instance.TensorNetwork`: `TNET e`, matrices kept as tensor networks over lists of+  dimensions, a hypergraph category whose structure costs nothing; `einsum` in it contracts pairwise.+  `Scalar`, the entry types, with a contraction loop compiled for each, which hands matrix products of+  `Double`, `Float` and `Complex Double` entries to the system's BLAS with the new `blas` flag.+  Biproducts as direct sums, the dagger, distributivity and traces, as in `Mat`; entries in and out as+  storable vectors (`fromVector`, `toVector`) or lists of rows.+* `Proarrow.Category.Instance.FinHask`: `unionFind`, the representatives after joining pairs, used by the+  coequalizers of `FINHASK` and `FINSET`.+* `Proarrow.Optic.Iso`: `DecidableIso`, categories that decide whether two objects are isomorphic,+  with the isomorphism as an optic of any flavour; instances for `Mat`, `FinRel`, `SVG` and `DOT`.+* `Proarrow.Object`: `ListOf c xs`, a type-level list with the evidence `c` for each element as a+  value, with `KnownListOf`. It replaces the library's own list singletons:+  * `Strictified`: `SList` is removed; `sList` is a `ListOf Ob'`.+  * `Thin`: `FNil`/`FCons` are now `Nil`/`Cons`, and `HasFiniteDefault` is removed (`finite`+    defaults to `listOf`).+  * `Edges`: `ENil`/`ECons` are removed.+* `Proarrow.Object`: `SomeOf c`, a type with the evidence `c` known only at runtime, built with+  `Some @a`. In `Proarrow.Testing`, `Some k` is `SomeOf TestOb'`, and `MkSomeList` is replaced by+  `mkSomeList`.+* `Proarrow.Optic.Kaleidoscope`, `Proarrow.Optic.Grate`: kaleidoscopes and grates now need+  `CocommutativeComonoid m` instead of `Comonoid m`.+* `Proarrow.Category.Monoidal.Applicative`: `Alternative`'s superclass is `HasBinaryCoproducts j` and+  `Monoidal k` instead of `Distributive j`.+* `Proarrow.Optic.Traversal`: `fromTravVL` builds a `Traversal` from a Prelude traversal, with `Baz`+  as the witness.+* `Proarrow.Category.Monoidal.Distributive`: `Traversing`, a new component of+  `StrongDistributiveProfunctor`, and `Traversable (CorepStar t)`. Eliminating a traversal with an+  unbounded witness through the generic carrier no longer loops. The `Traversable` witness+  instances need `Distributive k` and `CopyDiscard k` instead of `Bicartesian k`.+* `Proarrow.Profunctor.Instance.Star`: `Traversable (Star (Prelude g))`;+  `Strong CoprodAction (Star f)` for any strong lax monoidal `f` and `Strong ProdAction (Star f)`+  for any functor on `Type`.+* `Proarrow.Tools.Diagrams.Svg`: the option `bendSpiders` draws a merge point followed by a discard+  point as a cap, and a unit point followed by a copy point as a cup; `slidePoints` moves unit and+  discard points next to what uses or makes their wire.+* `Proarrow.Category.Instance.Linear`: `CocommutativeComonoid (L (Ur a))` and+  `CocommutativeComonoid (L Bool)`.+ ## 0.2.0.0 -- 2026-10-04  * New `Proarrow.Tools.SMC`: linear HOAS for symmetric monoidal categories, with `do` notation,
mkdocs.sh view
@@ -15,23 +15,10 @@ # Both libraries render into one doc tree (Hackage has a single documentation set per package). # This is hand-rolled rather than `cabal haddock-project` because that documents the whole # project (proarrow-equipment included), nests pages per component (breaking published URLs and-# the flat tree `cabal upload --documentation` expects), and has no per-component haddock options-# (the --comments-module source template differs between src/ and testing/).-# The testing sublibrary goes first: its dependency pass re-renders the main library with the-# wrong source-link template, and the main run afterwards overwrites those pages correctly.-${CABAL} haddock lib:testing ${ARG_COMPILER} \-  --haddock-hyperlink-source \-  --haddock-html-location='https://hackage.haskell.org/package/$pkg-$version/docs' \-  --haddock-options="-    --comments-base=https://github.com/sjoerdvisscher/proarrow/-    --comments-module=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/testing/%{MODULE/.//}.hs-    --comments-entity=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/testing/%{MODULE/.//}.hs#L%L-    --pretty-html-    ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}}-    --odir=docs-    --dump-interface=docs/testing.haddock"--${CABAL} haddock lib:proarrow ${ARG_COMPILER} \+# the flat tree `cabal upload --documentation` expects). One invocation renders each library+# once; the source-link template names src/, and the testing modules are pointed at testing/+# below, where the per-entity links are corrected anyway.+${CABAL} haddock lib:proarrow lib:testing ${ARG_COMPILER} \   --haddock-hyperlink-source \   --haddock-html-location='https://hackage.haskell.org/package/$pkg-$version/docs' \   --haddock-options="@@ -40,13 +27,23 @@     --comments-entity=https://github.com/sjoerdvisscher/proarrow/blob/main/proarrow/src/%{MODULE/.//}.hs#L%L     --pretty-html     ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}}-    --odir=docs-    --dump-interface=docs/proarrow.haddock"+    --odir=docs" +# cabal writes the haddock interface of each library into its build directory; the newest ones+# are from the run above+version=$(awk '$1 == "version:" { print $2 }' proarrow.cabal)+main_iface=$(ls -t $(find ../dist-newstyle/build -path "*/proarrow-${version}/doc/*" -name proarrow.haddock) | head -1)+testing_iface=$(ls -t $(find ../dist-newstyle/build -path "*/proarrow-${version}/l/testing/*" -name testing.haddock) | head -1)+cp "$main_iface" docs/proarrow.haddock+cp "$testing_iface" docs/testing.haddock+ # regenerate the contents and index pages covering both libraries ${HADDOCK} --gen-contents --gen-index -o docs --title=proarrow ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}} \   --read-interface=,docs/proarrow.haddock \   --read-interface=,docs/testing.haddock++# the testing modules live under testing/, not src/+grep -rl 'proarrow/src/Proarrow/Testing' docs | xargs perl -pi -e 's|proarrow/src/(Proarrow/Testing[^"]*\.hs)|proarrow/testing/$1|g'  # the testing pages link to the main library's modules via hackage; make those links local grep -rl 'hackage.haskell.org/package/proarrow-' docs | xargs perl -pi -e 's|https://hackage.haskell.org/package/proarrow-[0-9.]+/docs/||g'
proarrow.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               proarrow-version:            0.2.0.0+version:            0.3.0.0 synopsis:           Category theory with a central role for profunctors description:     A library for doing category theory in Haskell with profunctors, rather@@ -33,6 +33,12 @@     lattice.dot     mkdocs.sh +flag blas+    description: Contract tensor networks of floating-point numbers with the system's BLAS: Accelerate+                 on macOS, OpenBLAS elsewhere.+    default: False+    manual: True+ common extensions     default-language: GHC2024     ghc-options:      -Wall@@ -74,6 +80,7 @@         Proarrow.Category.Instance.Constraint         Proarrow.Category.Instance.Coproduct         Proarrow.Category.Instance.Cospan+        Proarrow.Category.Instance.DecoratedCospan         Proarrow.Category.Instance.Cps         Proarrow.Category.Instance.Cost         Proarrow.Category.Instance.Discrete@@ -91,6 +98,7 @@         Proarrow.Category.Instance.Mat         Proarrow.Category.Instance.Monoid         Proarrow.Category.Instance.Nat+        Proarrow.Category.Instance.OpenHypergraph         Proarrow.Category.Instance.PointedHask         Proarrow.Category.Instance.Product         Proarrow.Category.Instance.Prof@@ -99,6 +107,7 @@         Proarrow.Category.Instance.Simplex         Proarrow.Category.Instance.Span         Proarrow.Category.Instance.Sub+        Proarrow.Category.Instance.TensorNetwork         Proarrow.Category.Instance.Unit         Proarrow.Category.Instance.Zero         Proarrow.Category.Instance.ZX@@ -206,6 +215,17 @@         Proarrow.Squares         Proarrow.Tools.CCC         Proarrow.Tools.SMC+        Proarrow.Tools.Einsum+        Proarrow.Tools.SMC.Examples+        Proarrow.Tools.SMC.Internal.Additive+        Proarrow.Tools.SMC.Internal.Closed+        Proarrow.Tools.SMC.Internal.Context+        Proarrow.Tools.SMC.Internal.Dialogue+        Proarrow.Tools.SMC.Internal.Do+        Proarrow.Tools.SMC.Internal.Frobenius+        Proarrow.Tools.SMC.Internal.Pattern+        Proarrow.Tools.SMC.Internal.Syntax+        Proarrow.Tools.SMC.Internal.Term         Proarrow.Tools.DPO         Proarrow.Tools.Laws         Proarrow.Tools.Diagrams.Dot@@ -217,8 +237,17 @@         , containers >=0.6 && <0.9         , fin >= 0.3.2 && <1         , vec >= 0.5.1 && <1+        , vector >= 0.13 && <0.14         , universe-base >= 1.1.4 && <1.2     hs-source-dirs:   src+    other-modules:+        Proarrow.Category.Instance.TensorNetwork.Blas+    if flag(blas)+        cpp-options: -DBLAS+        if os(darwin)+            frameworks: Accelerate+        else+            extra-libraries: openblas  library testing     import: extensions@@ -246,6 +275,7 @@         Examples.Cofree         Examples.CustomLaws         Examples.Database+        Examples.Einsum         Examples.Free         Examples.FrontDoor         Examples.Readme@@ -261,10 +291,13 @@         Props.DPO         Props.Discrete         Props.Cospan+        Props.OpenHypergraph         Props.Cps         Props.Cost         Props.Dot+        Props.SMC         Props.Svg+        Props.TensorNetwork         Props.FinHask         Props.FinRel         Props.IntConstruction@@ -297,3 +330,4 @@         , universe-base >= 1.1.4 && <1.2         , tasty >=1.4 && <1.6         , tasty-falsify >=0.1 && <0.2+        , vector >= 0.13 && <0.14
src/Proarrow/Category/Enriched/Finitary.hs view
@@ -34,7 +34,6 @@   , Enumerable (..)   , Finite (..)   , Indexed (..)-  , IndexedList (..)   ) import Proarrow.Category.Instance.Bool (Booleans) import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))@@ -43,6 +42,7 @@ import Proarrow.Category.Instance.Unit (Unit (..)) import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), type (+->)) import Proarrow.Functor (FunctorForRep (..), withMappedOb)+import Proarrow.Object (mapListOf) import Proarrow.Profunctor.Corepresentable (Corep (..)) import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Initial (InitialProfunctor)@@ -94,11 +94,7 @@  -- | Everything an enumeration of a kind's objects can do at each of them, concatenated. foreachOb :: forall k r. (Enumerable k) => (forall (a :: k). (Ob a) => [r]) -> [r]-foreachOb f = go (finite @k)-  where-    go :: forall (as :: [k]). IndexedList as -> [r]-    go FNil = []-    go (FCons @a as) = withOb @k @a (f @a) P.++ go as+foreachOb f = P.concat (mapListOf (\ @a -> withOb @k @a (f @a)) (finite @k))  -- * Thin profunctors
src/Proarrow/Category/Enriched/Finitary/Topos.hs view
@@ -39,7 +39,7 @@   , Enumerable (..)   , Finite (..)   , Indexed (..)-  , IndexedList (..)+  , IndexedList   , KnownList (..)   ) import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))@@ -73,6 +73,7 @@ import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..)) import Proarrow.Limit.Equalizer (HasEqualizers (..)) import Proarrow.Limit.Pullback (HasPullbacks)+import Proarrow.Object (KnownListOf (..), ListOf (..), mapListOf) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Exponential ((:~>:) (..))@@ -90,10 +91,11 @@  type FIN (p :: j +-> k) = SUB p :: FINITARY j k --- The finite products and coproducts of 'FINITARY' (and of the sheaves) are the generic ones--- for a full subcategory in "Proarrow.Category.Instance.Sub", pointwise under 'Sub'. The predicate--- only has to hold of the ambient (co)products, which the instances for--- ':*:', ':+:', 'TerminalProfunctor' and 'InitialProfunctor' supply.+-- The finite products of 'FINITARY' (and of the sheaves) are the generic ones for a full+-- subcategory in "Proarrow.Category.Instance.Sub", pointwise under 'Sub'; the predicate only has to+-- hold of ':*:' and 'TerminalProfunctor'. The coproducts are defined here, from ':+:' and+-- 'InitialProfunctor': a full subcategory has no generic coproducts, since the sheaves, a full+-- subcategory too, have sheafified ones.  instance (CategoryOf j, CategoryOf k) => HasInitialObject (FINITARY j k) where   type InitialObject = FIN InitialProfunctor@@ -109,25 +111,19 @@ -- * Tables of fibres  -- | A type-level list of naturals, reflected.-class KnownNats (ns :: [Nat]) where-  natsVal :: [Natural]--instance KnownNats '[] where-  natsVal = []+type KnownNats :: [Nat] -> Constraint+type KnownNats = KnownListOf SNatI -instance (SNatI n, KnownNats ns) => KnownNats (n ': ns) where-  natsVal = N.snatToNatural (snat @n) : natsVal @ns+natsVal :: forall ns. (KnownNats ns) => [Natural]+natsVal = mapListOf @SNatI (\ @n -> N.snatToNatural (snat @n)) (listOf @SNatI @ns)  -- | A type-level list of lists of naturals, reflected: the fibres of a partial surjection out of -- one hom-set.-class KnownFibres (fs :: [[Nat]]) where-  fibresVal :: [[Natural]]--instance KnownFibres '[] where-  fibresVal = []+type KnownFibres :: [[Nat]] -> Constraint+type KnownFibres = KnownListOf KnownNats -instance (KnownNats f, KnownFibres fs) => KnownFibres (f ': fs) where-  fibresVal = natsVal @f : fibresVal @fs+fibresVal :: forall fs. (KnownFibres fs) => [[Natural]]+fibresVal = mapListOf @KnownNats (\ @f -> natsVal @f) (listOf @KnownNats @fs)  -- | Reify a list of lists of naturals. fibres :: forall r. [[Natural]] -> (forall fs. (KnownFibres fs) => r) -> r@@ -151,12 +147,12 @@ buildTable cell = rows (finite @k)   where     rows :: forall (as :: [k]) r'. IndexedList as -> (forall t. (KnownTable (Objects j) as t) => r') -> r'-    rows FNil k' = k' @'[]-    rows (FCons @a as) k' = withOb @k @a (row @a (finite @j) \ @r0 -> rows as \ @t -> k' @(r0 ': t))+    rows Nil k' = k' @'[]+    rows (Cons @a as) k' = withOb @k @a (row @a (finite @j) \ @r0 -> rows as \ @t -> k' @(r0 ': t))     row       :: forall (a :: k) (bs :: [j]) r'. (Ob a) => IndexedList bs -> (forall r0. (KnownList KnownFibres bs r0) => r') -> r'-    row FNil k' = k' @'[]-    row (FCons @b bs) k' = withOb @j @b (fibres (cell @a @b) \ @fs -> row @a bs \ @r0 -> k' @(fs ': r0))+    row Nil k' = k' @'[]+    row (Cons @b bs) k' = withOb @j @b (fibres (cell @a @b) \ @fs -> row @a bs \ @r0 -> k' @(fs ': r0))  -- * Reindexing along a table of fibres
src/Proarrow/Category/Enriched/Thin.hs view
@@ -17,6 +17,7 @@ import Proarrow.Category.Instance.Bool (BOOL (..), BoolLeq, Booleans (..), NonTrivialHolds, NonTrivialProfunctor (..)) import Proarrow.Category.Instance.Zero (Bottom (..), VOID, Zero) import Proarrow.Core (CAT, CategoryOf (..), Hom, Kind, Profunctor (..), VacuousOb, obj, type (+->))+import Proarrow.Object (KnownListOf (..), ListOf (..))  -- | The defaults take everything from a 'DecidableProfunctor' instance: the arrow exists when -- @'Holds' p a b@ computes to 'TRU'.@@ -248,27 +249,16 @@  -- | A type-level list of inhabitants, reflected to the value level with their indices. type IndexedList :: forall k. [k] -> Type-data IndexedList as where-  FNil :: IndexedList '[]-  FCons :: forall a as. (KnownIndex a) => IndexedList as -> IndexedList (a ': as)---- | Every element of the list is numbered, so the list can be reflected to an 'IndexedList'. So a--- kind that simply writes its objects out gets 'finite' for free.-class HasFiniteDefault (xs :: [k]) where-  finiteDefault :: IndexedList xs--instance HasFiniteDefault '[] where-  finiteDefault = FNil-instance (KnownIndex a, HasFiniteDefault as) => HasFiniteDefault (a ': as) where-  finiteDefault = FCons finiteDefault+type IndexedList @k = ListOf (KnownIndex :: k -> Constraint)  -- | An 'Indexed' kind with finitely many inhabitants, listed in 'Objects' in the order of their--- indices: 'withAtLookup' says that the list tabulates 'At'.+-- indices: 'withAtLookup' says that the list tabulates 'At'. A kind that writes its objects out+-- gets 'finite' from 'listOf', since each of them is numbered. class (Indexed k) => Finite k where   type Objects k :: [k]   finite :: IndexedList (Objects k)-  default finite :: (HasFiniteDefault (Objects k)) => IndexedList (Objects k)-  finite = finiteDefault+  default finite :: (KnownListOf KnownIndex (Objects k)) => IndexedList (Objects k)+  finite = listOf   withAtLookup :: forall (i :: Nat) r. SNat i -> ((Lookup (Objects k) i ~ At k i) => r) -> r   default withAtLookup     :: forall (i :: Nat) r. (At k i ~ Lookup (Objects k) i) => SNat i -> ((Lookup (Objects k) i ~ At k i) => r) -> r@@ -285,8 +275,8 @@ memberIndex = withAtLookup @k (snat @(Index a)) (go (snat @(Index a)) (finite @k))   where     go :: forall i xs. (Lookup xs i ~ 'Just a) => SNat i -> IndexedList xs -> Member a xs-    go SZ (FCons _) = Here-    go (SS @i') (FCons xs) = There (go (snat @i') xs)+    go SZ (Cons _) = Here+    go (SS @i') (Cons xs) = There (go (snat @i') xs)  -- | A category on a 'Finite' kind whose objects are exactly its numbered inhabitants: 'withIndex' -- and 'withOb' convert between the two notions, and 'atOb' looks an object up by its index.@@ -339,15 +329,15 @@   :: forall {j} {k} (w :: j -> k) xs    . (forall (a :: j). (KnownIndex a) => KnownIndex (w a))   => IndexedList xs -> IndexedList (MapWrap w xs)-mapWrap FNil = FNil-mapWrap (FCons @a xs) = FCons @(w a) (mapWrap @w xs)+mapWrap Nil = Nil+mapWrap (Cons @a xs) = Cons @(w a) (mapWrap @w xs)  withLookupMapWrap   :: forall {j} {k} (w :: j -> k) xs i r    . SNat i -> IndexedList xs -> ((Lookup (MapWrap w xs) i ~ FmapWrap w (Lookup xs i)) => r) -> r-withLookupMapWrap _ FNil r = r-withLookupMapWrap SZ (FCons _) r = r-withLookupMapWrap (SS @i') (FCons xs) r = withLookupMapWrap @w (snat @i') xs r+withLookupMapWrap _ Nil r = r+withLookupMapWrap SZ (Cons _) r = r+withLookupMapWrap (SS @i') (Cons xs) r = withLookupMapWrap @w (snat @i') xs r  -- | The two 'Finite' methods of a wrapper kind, which are the same for every wrapper. wrapFinite@@ -364,9 +354,9 @@  -- | The default 'atOb': walk the object list to the index. lookupOb :: forall k (j :: Nat) xs. (Enumerable k) => SNat j -> IndexedList (xs :: [k]) -> AtOb k (Lookup xs j)-lookupOb _ FNil = AtNothing-lookupOb SZ (FCons @a _) = withOb @k @a AtJust-lookupOb (SS @j') (FCons xs) = lookupOb @k (snat @j') xs+lookupOb _ Nil = AtNothing+lookupOb SZ (Cons @a _) = withOb @k @a AtJust+lookupOb (SS @j') (Cons xs) = lookupOb @k (snat @j') xs  instance Indexed BOOL
src/Proarrow/Category/Enriched/Thin/Composition.hs view
@@ -21,7 +21,7 @@   , Decision (..)   , Enumerable (..)   , Finite (..)-  , IndexedList (..)+  , IndexedList   , Length   , Member (..)   , Thin@@ -37,7 +37,7 @@ import Proarrow.Core (CategoryOf (..), Hom, Kind, Profunctor (..), Promonad (..), obj, type (+->)) import Proarrow.Core qualified as P import Proarrow.Functor (FunctorForRep (..), withMappedOb)-import Proarrow.Object (pattern Objs)+import Proarrow.Object (ListOf (..), pattern Objs) import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), withObCorep) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..), withObRep)@@ -140,8 +140,8 @@   :: forall {i} {j} {k} (p :: j +-> k) (q :: i +-> j) (a :: k) (c :: i) (bs :: [j])    . (DecidableProfunctor p, DecidableProfunctor q, Enumerable j, Ob a, Ob c)   => IndexedList bs -> Decision (p :.: q) a c (Search bs p q a c)-search FNil = No-search (FCons @b bs) = withOb @j @b case (decide @p @a @b, decide @q @b @c) of+search Nil = No+search (Cons @b bs) = withOb @j @b case (decide @p @a @b, decide @q @b @c) of   (Yes x, Yes y) -> Yes (x :.: y)   (No, _) -> search @p @q @a @c bs   (Yes _, No) -> search @p @q @a @c bs@@ -302,14 +302,14 @@ row = case snat @n of   SZ ->     let homRow :: forall as. IndexedList as -> Row v 'Z p b as (MatCol v as (Hom k) b)-        homRow FNil = RNil-        homRow (FCons @a as) = withOb @k @a (withProObj @v @(Hom k) @a @b (RCons (homRow as)))+        homRow Nil = RNil+        homRow (Cons @a as) = withOb @k @a (withProObj @v @(Hom k) @a @b (RCons (homRow as)))     in homRow (finite @k)   SS @n' ->     let prev = row @v @n' @p @b         nextRow :: forall as. IndexedList as -> Row v ('S n') p b as (NextRow v as (WalkRow v n' p b) p b)-        nextRow FNil = RNil-        nextRow (FCons @a as) =+        nextRow Nil = RNil+        nextRow (Cons @a as) =           withOb @k @a             ( withProObj @v @(Hom k) @a @b                 ( withObMatVec @a
src/Proarrow/Category/Instance/Collage.hs view
@@ -24,7 +24,7 @@   , Finite (..)   , FmapWrap   , Indexed (..)-  , IndexedList (..)+  , IndexedList   , KnownIndex   , Length   , Lookup@@ -56,6 +56,7 @@   ) import Proarrow.Functor (FunctorForRep (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..), terminate')+import Proarrow.Object (ListOf (..)) import Proarrow.Optic (iso) import Proarrow.Optic.Iso (Iso') import Proarrow.Profunctor.Instance.Direp (Direp (..))@@ -196,8 +197,8 @@       :: forall xs i        . (Lookup xs i ~ 'Just x)       => IndexedList xs -> SNat i -> ((Lookup (CollageObjects p xs) i ~ 'Just (L x)) => r) -> r-    go (FCons _) SZ k = k-    go (FCons xs) (SS @i') k = go xs (snat @i') k+    go (Cons _) SZ k = k+    go (Cons xs) (SS @i') k = go xs (snat @i') k  withCollageR   :: forall {j} {k} (p :: k +-> j) (y :: k) r@@ -214,19 +215,19 @@            => r          )       -> r-    go FNil k = withWrapAtLookup @(R :: k -> COLLAGE p) (snat @(Index y)) k-    go (FCons xs) k = go xs k+    go Nil k = withWrapAtLookup @(R :: k -> COLLAGE p) (snat @(Index y)) k+    go (Cons xs) k = go xs k  instance (Finite j, Finite k) => Finite (COLLAGE (p :: k +-> j)) where   type Objects (COLLAGE (p :: k +-> j)) = CollageObjects p (Objects j)   finite = goL (finite @j)     where       goL :: forall xs. IndexedList xs -> IndexedList (CollageObjects p xs)-      goL FNil = goR (finite @k)-      goL (FCons @x xs) = withCollageL @p @x (FCons @(L x) (goL xs))+      goL Nil = goR (finite @k)+      goL (Cons @x xs) = withCollageL @p @x (Cons @(L x) (goL xs))       goR :: forall ys. IndexedList ys -> IndexedList (MapWrap (R :: k -> COLLAGE p) ys)-      goR FNil = FNil-      goR (FCons @y ys) = withCollageR @p @y (FCons @(R y) (goR ys))+      goR Nil = Nil+      goR (Cons @y ys) = withCollageR @p @y (Cons @(R y) (goR ys))  -- | The collage of a finitary profunctor between finite categories is a finite category: a -- hom-set is a base hom-set, an element set of @p@ for a cross-arrow, or empty going back.@@ -260,8 +261,8 @@   atOb = go (finite @j)     where       go :: forall xs i. IndexedList xs -> SNat i -> AtOb (COLLAGE p) (Lookup (CollageObjects p xs) i)-      go FNil i = withWrapAtLookup @(R :: k -> COLLAGE p) i case atOb @k i of+      go Nil i = withWrapAtLookup @(R :: k -> COLLAGE p) i case atOb @k i of         AtJust @_ @y -> withCollageR @p @y AtJust         AtNothing -> AtNothing-      go (FCons @x _) SZ = withOb @j @x (withCollageL @p @x AtJust)-      go (FCons xs) (SS @i') = go xs (snat @i')+      go (Cons @x _) SZ = withOb @j @x (withCollageL @p @x AtJust)+      go (Cons xs) (SS @i') = go xs (snat @i')
src/Proarrow/Category/Instance/Cospan.hs view
@@ -1,125 +1,76 @@+{-# LANGUAGE PatternSynonyms #-}+ -- | The category of __cospans__ in @k@: objects are those of @k@ (wrapped in 'CS'), and a morphism -- @a '~>' b@ is a cospan @a -> x <- b@, composed by pushout. With the coproduct of @k@ as tensor -- every object is a Frobenius monoid, giving a 'Proarrow.Category.Monoidal.Hypergraph.Hypergraph', -- compact closed, dagger category. This is the archetypal setting for undirected wiring diagrams.-module Proarrow.Category.Instance.Cospan where+--+-- These are the decorated cospans of "Proarrow.Category.Instance.DecoratedCospan" without a+-- decoration, which is where their structure comes from.+module Proarrow.Category.Instance.Cospan+  ( COSPAN+  , CS+  , Cospan+  , pattern Cospan+  , Undecorated (..)+  , arr+  , coarr+  , Pushout+  , Pullback+  ) where -import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Data.Kind (Type)+import Prelude (type (~))++import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..)) import Proarrow.Category.Instance.Span (SPAN (..), Span (..))-import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))-import Proarrow.Category.Monoidal.Closed (Closed (..))-import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))-import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)-import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))-import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, applyHG, cap, cup, curryHG)-import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))-import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))-import Proarrow.Colimit.BinaryCoproduct-  ( HasBinaryCoproducts (..)-  , HasCoproducts-  , associatorCoprod-  , associatorCoprodInv-  , leftUnitorCoprod-  , leftUnitorCoprodInv-  , rightUnitorCoprod-  , rightUnitorCoprodInv-  , swapCoprod-  )-import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Category.Monoidal.Applicative (Alternative (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasCoproducts) import Proarrow.Colimit.Pushout (HasPushouts (..))-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, tgt, type (+->))-import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Core (CAT, CategoryOf (..), tgt, type (+->))+import Proarrow.Functor (Functor (..), FunctorForRep (..)) import Proarrow.Limit.Pullback (HasPullbacks (..))-import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..)) -type data COSPAN k = CS k--type Cospan :: CAT (COSPAN k)-data Cospan a b where-  Cospan :: forall c a b. a ~> c -> b ~> c -> Cospan (CS a) (CS b)--arr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS a) (CS b)-arr f = Cospan f (tgt f)--coarr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS b) (CS a)-coarr f = Cospan (tgt f) f+-- | The decoration that says nothing.+type Undecorated :: k -> Type+data Undecorated c = Undecorated -instance (HasPushouts k) => Profunctor (Cospan :: CAT (COSPAN k)) where-  dimap = dimapDefault-  r \\ Cospan f g = r \\ f \\ g-instance (HasPushouts k) => Promonad (Cospan :: CAT (COSPAN k)) where-  id = Cospan id id-  Cospan f g . Cospan h i = pushout i f \l r -> Cospan (l . h) (r . g)+instance (CategoryOf k) => Functor (Undecorated :: k -> Type) where+  map _ Undecorated = Undecorated --- | The category of cospans in @k@: an arrow @'CS' a '~>' 'CS' b@ is a pair of arrows--- @a '~>' x@ and @b '~>' x@ into a common object, and composition glues along a pushout.-instance (HasPushouts k) => CategoryOf (COSPAN k) where-  type (~>) = Cospan-  type Ob a = WrappedOb CS a+instance (HasBinaryCoproducts k) => Alternative (Undecorated :: k -> Type) where+  empty () = Undecorated+  alt _ _ = Undecorated -instance (HasPushouts k, HasCoproducts k) => MonoidalProfunctor (Cospan :: CAT (COSPAN k)) where-  one = id-  Cospan l1 l2 ** Cospan r1 r2 = Cospan (l1 +++ r1) (l2 +++ r2)-instance (HasPushouts k, HasCoproducts k) => Monoidal (COSPAN k) where-  type CS a ** CS b = CS (a || b)-  type Unit = CS InitialObject-  withOb2 @(CS a) @(CS b) r = withObCoprod @k @a @b r-  leftUnitor = arr leftUnitorCoprod-  leftUnitorInv = arr leftUnitorCoprodInv-  rightUnitor = arr rightUnitorCoprod-  rightUnitorInv = arr rightUnitorCoprodInv-  associator @(CS a) @(CS b) @(CS c) = arr (associatorCoprod @a @b @c)-  associatorInv @(CS a) @(CS b) @(CS c) = arr (associatorCoprodInv @a @b @c)-instance (HasPushouts k, HasCoproducts k) => SymMonoidal (COSPAN k) where-  swap @(CS a) @(CS b) = arr (swapCoprod @a @b)+type COSPAN :: Type -> Type+type COSPAN k = DECCOSPAN (Undecorated :: k -> Type) -instance (HasPushouts k, HasCoproducts k, Ob a) => Monoid (CS (a :: k)) where-  mempty = arr initiate-  mappend = arr (id ||| id)-instance (HasPushouts k, HasCoproducts k, Ob a) => CommutativeMonoid (CS (a :: k))-instance (HasPushouts k, HasCoproducts k, Ob a) => Comonoid (CS (a :: k)) where-  counit = coarr initiate-  comult = coarr (id ||| id)-instance (HasPushouts k, HasCoproducts k, Ob a) => CocommutativeComonoid (CS (a :: k))-instance (HasPushouts k, HasCoproducts k, Ob a) => Frobenius (CS (a :: k))-instance (HasPushouts k, HasCoproducts k) => Hypergraph (COSPAN k)-instance (HasPushouts k, HasCoproducts k) => CopyDiscard (COSPAN k)+-- | An object of @k@ as one of 'COSPAN' @k@.+type CS :: forall k. k -> COSPAN k+type CS @k = DC @k @Undecorated -instance (HasPushouts k, HasCoproducts k) => Closed (COSPAN k) where-  type a ~~> b = ExpHG a b-  withObExp @(CS a) @(CS b) r = withObCoprod @k @a @b r-  curry @a @b = curryHG @a @b-  apply @b @c = applyHG @b @c+type Cospan :: forall k. CAT (COSPAN k)+type Cospan @k = DecCospan @(Undecorated :: k -> Type) -instance (HasPushouts k, HasCoproducts k) => Dialogue (COSPAN k) where-  type Dual a = a-  withObDual r = r-  dual = dagger-  linDist @(CS a) @(CS b) (Cospan f g) = Cospan (f . lft @k @a @b) (f . rgt @k @a @b ||| g)-  linDistInv @_ @(CS b) @(CS c) (Cospan f g) = Cospan (f ||| g . lft @k @b @c) (g . rgt @k @b @c)-  doubleNegInv = id+-- | A cospan @a -> c <- b@.+pattern Cospan+  :: forall {k} {a :: COSPAN k} {b}. () => forall c a' b'. (a ~ CS a', b ~ CS b') => a' ~> c -> b' ~> c -> Cospan a b+pattern Cospan f g = DecCospan f g Undecorated -instance (HasPushouts k, HasCoproducts k) => StarAutonomous (COSPAN k) where-  dualInv = dagger-  doubleNeg = id-instance (HasPushouts k, HasCoproducts k) => IsoMix (COSPAN k) where-  dualUnit = id-  dualUnitInv = id-  dualityCounit @a = cap @a+{-# COMPLETE Cospan #-} -instance (HasPushouts k, HasCoproducts k) => CompactClosed (COSPAN k) where-  distribDual @(CS a) @(CS b) = withObCoprod @k @a @b id-  dualityUnit @a = cup @a+arr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS a) (CS b)+arr f = Cospan f (tgt f) -instance (HasPushouts k) => DaggerProfunctor (Cospan :: CAT (COSPAN k)) where-  dagger (Cospan f g) = Cospan g f+coarr :: (CategoryOf k) => (a :: k) ~> b -> Cospan (CS b) (CS a)+coarr f = Cospan (tgt f) f  data family Pushout :: SPAN k +-> COSPAN k-instance (HasPushouts k, HasPullbacks k) => FunctorForRep (Pushout :: SPAN k +-> COSPAN k) where+instance (HasPushouts k, HasCoproducts k, HasPullbacks k) => FunctorForRep (Pushout :: SPAN k +-> COSPAN k) where   type Pushout @ (SP a) = CS a   fmap (Span l r) = pushout l r Cospan  data family Pullback :: COSPAN k +-> SPAN k-instance (HasPushouts k, HasPullbacks k) => FunctorForRep (Pullback :: COSPAN k +-> SPAN k) where+instance (HasPushouts k, HasCoproducts k, HasPullbacks k) => FunctorForRep (Pullback :: COSPAN k +-> SPAN k) where   type Pullback @ (CS a) = SP a   fmap (Cospan l r) = pullback l r Span
+ src/Proarrow/Category/Instance/DecoratedCospan.hs view
@@ -0,0 +1,125 @@+-- | __Decorated cospans__ in @k@: a morphism @a '~>' b@ is a cospan @a -> x <- b@ together with a+-- decoration of its apex, a value of @f x@. Composition glues along a pushout and joins the two+-- decorations on the glued apex, using the 'Alternative' structure of @f@, which takes decorations+-- on two objects to one on their coproduct. As for "Proarrow.Category.Instance.Cospan", the+-- coproduct of @k@ is the tensor and every object is a Frobenius monoid, so this is a+-- 'Hypergraph' category.+--+-- With labelled boxes as the decoration, a morphism is an open hypergraph: see+-- "Proarrow.Category.Instance.OpenHypergraph".+module Proarrow.Category.Instance.DecoratedCospan where++import Data.Kind (Type)++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Applicative (Alternative (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.Hypergraph (ExpHG, Frobenius, Hypergraph, Sized (..), applyHG, cap, cup, curryHG)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Colimit.BinaryCoproduct+  ( HasBinaryCoproducts (..)+  , HasCoproducts+  , associatorCoprod+  , associatorCoprodInv+  , leftUnitorCoprod+  , leftUnitorCoprodInv+  , rightUnitorCoprod+  , rightUnitorCoprodInv+  , swapCoprod+  )+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, tgt)+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))++type data DECCOSPAN (f :: k -> Type) = DC k++type DecCospan :: CAT (DECCOSPAN f)+data DecCospan a b where+  DecCospan :: forall {k} {f :: k -> Type} c a b. a ~> c -> b ~> c -> f c -> DecCospan (DC a :: DECCOSPAN f) (DC b)++-- | A morphism of @k@ as a cospan with the empty decoration.+arr :: forall {k} (f :: k -> Type) a b. (Alternative f) => a ~> b -> DecCospan (DC a :: DECCOSPAN f) (DC b)+arr f = DecCospan f (tgt f) (empty ()) \\ f++-- | A morphism of @k@ as a cospan the other way round, with the empty decoration.+coarr :: forall {k} (f :: k -> Type) a b. (Alternative f) => a ~> b -> DecCospan (DC b :: DECCOSPAN f) (DC a)+coarr f = DecCospan (tgt f) f (empty ()) \\ f++instance (HasPushouts k, Alternative f) => Profunctor (DecCospan :: CAT (DECCOSPAN (f :: k -> Type))) where+  dimap = dimapDefault+  r \\ DecCospan f g _ = r \\ f \\ g+instance (HasPushouts k, Alternative f) => Promonad (DecCospan :: CAT (DECCOSPAN (f :: k -> Type))) where+  id = arr id+  DecCospan f g s . DecCospan h i t = pushout i f \l r -> DecCospan (l . h) (r . g) (alt (l ||| r) (t, s)) \\ i \\ f++-- | The category of decorated cospans in @k@: an arrow @'DC' a '~>' 'DC' b@ is a pair of arrows+-- @a '~>' x@ and @b '~>' x@ into a common object, with a decoration of @x@.+instance (HasPushouts k, Alternative f) => CategoryOf (DECCOSPAN (f :: k -> Type)) where+  type (~>) = DecCospan+  type Ob a = WrappedOb DC a++instance (HasPushouts k, HasCoproducts k, Alternative f) => MonoidalProfunctor (DecCospan :: CAT (DECCOSPAN (f :: k -> Type))) where+  one = id+  DecCospan @c1 l1 l2 s ** DecCospan @c2 r1 r2 t =+    withObCoprod @k @c1 @c2 (DecCospan (l1 +++ r1) (l2 +++ r2) (alt id (s, t))) \\ l1 \\ r1+instance (HasPushouts k, HasCoproducts k, Alternative f) => Monoidal (DECCOSPAN (f :: k -> Type)) where+  type DC a ** DC b = DC (a || b)+  type Unit = DC InitialObject+  withOb2 @(DC a) @(DC b) r = withObCoprod @k @a @b r+  leftUnitor = arr leftUnitorCoprod+  leftUnitorInv = arr leftUnitorCoprodInv+  rightUnitor = arr rightUnitorCoprod+  rightUnitorInv = arr rightUnitorCoprodInv+  associator @(DC a) @(DC b) @(DC c) = arr (associatorCoprod @a @b @c)+  associatorInv @(DC a) @(DC b) @(DC c) = arr (associatorCoprodInv @a @b @c)+instance (HasPushouts k, HasCoproducts k, Alternative f) => SymMonoidal (DECCOSPAN (f :: k -> Type)) where+  swap @(DC a) @(DC b) = arr (swapCoprod @a @b)++instance (HasPushouts k, HasCoproducts k, Alternative f, Ob a) => Monoid (DC a :: DECCOSPAN (f :: k -> Type)) where+  mempty = arr initiate+  mappend = arr (id ||| id)+instance (HasPushouts k, HasCoproducts k, Alternative f, Ob a) => CommutativeMonoid (DC a :: DECCOSPAN (f :: k -> Type))+instance (HasPushouts k, HasCoproducts k, Alternative f, Ob a) => Comonoid (DC a :: DECCOSPAN (f :: k -> Type)) where+  counit = coarr initiate+  comult = coarr (id ||| id)+instance (HasPushouts k, HasCoproducts k, Alternative f, Ob a) => CocommutativeComonoid (DC a :: DECCOSPAN (f :: k -> Type))+instance (HasPushouts k, HasCoproducts k, Alternative f, Ob a) => Frobenius (DC a :: DECCOSPAN (f :: k -> Type))+instance (HasPushouts k, HasCoproducts k, Alternative f) => Hypergraph (DECCOSPAN (f :: k -> Type))+instance (HasPushouts k, HasCoproducts k, Alternative f) => CopyDiscard (DECCOSPAN (f :: k -> Type))+instance (HasPushouts k, Alternative f) => Sized (DECCOSPAN (f :: k -> Type)) where+  sizeOf = 2++instance (HasPushouts k, HasCoproducts k, Alternative f) => Closed (DECCOSPAN (f :: k -> Type)) where+  type a ~~> b = ExpHG a b+  withObExp @(DC a) @(DC b) r = withObCoprod @k @a @b r+  curry @a @b = curryHG @a @b+  apply @b @c = applyHG @b @c++instance (HasPushouts k, HasCoproducts k, Alternative f) => Dialogue (DECCOSPAN (f :: k -> Type)) where+  type Dual a = a+  withObDual r = r+  dual = dagger+  linDist @(DC a) @(DC b) (DecCospan f g s) = DecCospan (f . lft @k @a @b) (f . rgt @k @a @b ||| g) s+  linDistInv @_ @(DC b) @(DC c) (DecCospan f g s) = DecCospan (f ||| g . lft @k @b @c) (g . rgt @k @b @c) s+  doubleNegInv = id++instance (HasPushouts k, HasCoproducts k, Alternative f) => StarAutonomous (DECCOSPAN (f :: k -> Type)) where+  dualInv = dagger+  doubleNeg = id+instance (HasPushouts k, HasCoproducts k, Alternative f) => IsoMix (DECCOSPAN (f :: k -> Type)) where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a++instance (HasPushouts k, HasCoproducts k, Alternative f) => CompactClosed (DECCOSPAN (f :: k -> Type)) where+  distribDual @(DC a) @(DC b) = withObCoprod @k @a @b id+  dualityUnit @a = cup @a++instance (HasPushouts k, Alternative f) => DaggerProfunctor (DecCospan :: CAT (DECCOSPAN (f :: k -> Type))) where+  dagger (DecCospan f g s) = DecCospan g f s
src/Proarrow/Category/Instance/FinHask.hs view
@@ -238,13 +238,19 @@     in       reifyList groups \e -> k (FinHask (P.fst P.<$> e)) (FinHask (P.snd P.<$> e)) +-- | The representative of each element after joining the given pairs: union-find, on a map of+-- parent pointers.+unionFind :: (P.Ord a) => [(a, a)] -> a -> a+unionFind pairs = find (P.foldl union M.empty pairs)+  where+    find m i = P.maybe i (find m) (M.lookup i m)+    union m (i, j) = let ri = find m i; rj = find m j in if ri P.== rj then m else M.insert ri rj m+ instance HasCoequalizers FINHASK where   coequalize (FinHask @_ @b f) (FinHask g) k =     let-      find m i = P.maybe i (find m) $ M.lookup i m-      union m (i, j) = let ri = find m i; rj = find m j in if ri P.== rj then m else M.insert ri rj m-      unionFind = P.foldl union M.empty (P.zip (M.elems f) (M.elems g))-      step m x = M.insertWith (P.++) (find unionFind x) [x] m+      rep = unionFind (P.zip (M.elems f) (M.elems g))+      step m x = M.insertWith (P.++) (rep x) [x] m       groups = M.elems $ P.foldl step M.empty (universeF @b)     in       reifyList groups \ce ->
src/Proarrow/Category/Instance/FinRel.hs view
@@ -7,7 +7,8 @@ module Proarrow.Category.Instance.FinRel where  import Data.Fin (Fin (..))-import Data.Type.Nat (Mult, Nat (..), Nat0, Nat1, Plus, SNat (..), SNatI, snat, snatToNatural)+import Data.Type.Equality ((:~:) (..))+import Data.Type.Nat (Mult, Nat (..), Nat0, Nat1, Plus, SNat (..), SNatI, eqNat, snat, snatToNatural) import Data.Vec.Lazy (Vec (..), chunks, concatMap, repeat, universe, zipWith, (++)) import GHC.Bits qualified as B import GHC.Natural (Natural)@@ -23,7 +24,7 @@ import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard) import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Distributive (..))-import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cap, cup) import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..))@@ -34,6 +35,7 @@ import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..)) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality) import Proarrow.Profunctor.Representable (Rep (..))  newtype Bitstring (n :: Nat) = BS Natural@@ -238,6 +240,15 @@ instance (SNatI a) => Frobenius (FR a) instance (SNatI a) => CommutativeMonoid (FR a) instance Hypergraph FINREL++-- | @FR n@ and @FR m@ are isomorphic when @n@ and @m@ are equal.+instance DecidableIso FINREL where+  isoOf @_ @(FR n) @(FR m) = isoFromEquality (P.fmap (\Refl -> Refl) (eqNat @n @m))++-- | The size of @FR n@ is its number of elements, @n@.+instance Sized FINREL where+  sizeOf @(FR n) = fromIntegral (snatToNatural (snat @n))+ instance CopyDiscard FINREL  data family Fun :: FINSET +-> FINREL
src/Proarrow/Category/Instance/FinSet.hs view
@@ -32,6 +32,7 @@ import Prelude (($)) import Prelude qualified as P +import Proarrow.Category.Instance.FinHask (unionFind) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..)) import Proarrow.Category.Monoidal.Closed (Closed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)@@ -290,10 +291,8 @@ instance HasCoequalizers FINSET where   coequalize (FinSet @_ @a f) (FinSet g) k =     let-      find m i = P.maybe i (find m) $ IM.lookup (P.fromEnum i) m-      union m (i, j) = let ri = find m i; rj = find m j in if ri P.== rj then m else IM.insert (P.fromEnum ri) rj m-      unionFind = P.foldl union IM.empty (zipWith (,) f g)-      step m x = IM.insertWith (P.++) (P.fromEnum $ find unionFind x) [x] m+      rep = unionFind (toList (zipWith (,) f g))+      step m x = IM.insertWith (P.++) (P.fromEnum (rep x)) [x] m       groups = IM.elems $ P.foldl step IM.empty (universe @a)     in       reifyList groups \vec -> k (FinSet (tabulate (\a -> findIndex (P.elem a) vec)))
src/Proarrow/Category/Instance/IntConstruction.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE RecursiveDo #-}
src/Proarrow/Category/Instance/Linear.hs view
@@ -37,7 +37,7 @@ import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..)) import Proarrow.Limit.Power (Powered (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..))-import Proarrow.Monoid (Comonoid (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..)) import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..)) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Representable (Rep (..))@@ -144,12 +144,16 @@   counit = Linear \(Ur _) -> ()   comult = Linear \(Ur a) -> (Ur a, Ur a) +instance CocommutativeComonoid (L (Ur a))+ -- | @L Bool@ is a comonoid: a @Bool@ is duplicated and discarded by case analysis, which is -- linear (it consumes the input exactly once). The same holds for any finite, pattern-matchable -- classical type. Only the @Bool@ instance is spelled out here. instance Comonoid (L Bool) where   counit = Linear \case True -> (); False -> ()   comult = Linear \case True -> (True, True); False -> (False, False)++instance CocommutativeComonoid (L Bool)  instance HasBinaryCoproducts LINEAR where   type L a || L b = L (Either a b)
src/Proarrow/Category/Instance/Mat.hs view
@@ -9,13 +9,14 @@ module Proarrow.Category.Instance.Mat where  import Data.Complex (Complex, conjugate)+import Data.Fin (Fin) import Data.Kind (Type)-import Data.Type.Nat (Nat (..), SNat (..), SNatI, snat, snatToNat, type Mult, type Plus)+import Data.Type.Equality ((:~:) (..))+import Data.Type.Nat (Nat (..), SNat (..), SNatI, eqNat, snat, snatToNat, type Mult, type Plus) import Data.Vec.Lazy (Vec (..), chunks, concat, concatMap, reifyList, tabulate, toList, zipWith, (++)) import Prelude (($), type (~)) import Prelude qualified as P -import Data.Fin (Fin) import Proarrow.Adjunction (Involution) import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..)) import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..))@@ -26,7 +27,7 @@ import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard) import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Category.Monoidal.Distributive (Distributive (..), distLInv, distRInv)-import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cap, cup) import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..))@@ -42,6 +43,7 @@ import Proarrow.Limit.Pullback (HasPullbacks (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..)) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality) import Proarrow.Profunctor.Corepresentable (Corepresentable (..)) import Proarrow.Profunctor.Representable (Rep (..)) @@ -351,6 +353,15 @@ instance (P.Num a, IsNat n) => Frobenius (M n :: MatK a) instance (P.Num a, IsNat n) => CommutativeMonoid (M n :: MatK a) instance (P.Num a) => Hypergraph (MatK a)++-- | @M n@ and @M m@ are isomorphic when @n@ and @m@ are equal.+instance (P.Num a) => DecidableIso (MatK a) where+  isoOf @_ @(M n) @(M m) = isoFromEquality (P.fmap (\Refl -> Refl) (eqNat @n @m))++-- | The size of @M n@ is its dimension, @n@.+instance (P.Num a) => Sized (MatK a) where+  sizeOf @(M n) = P.fromIntegral (snatToNat (snat @n))+ instance (P.Num a) => CopyDiscard (MatK a)  data family Conjugate :: MatK (Complex a) +-> MatK (Complex a)
+ src/Proarrow/Category/Instance/OpenHypergraph.hs view
@@ -0,0 +1,880 @@+{-# 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+  , isomorphic+  , sameSort++    -- * Read-back+  , SomeArrow (..)+  , someArrow+  , readBack+  , readBackWith++    -- * Simplifying+  , SIMPLIFY+  , Prim+  , unsafePrim+  , prim+  , simplify+  , simplifyWith+  ) 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 (isJust)+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 (..))+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Applicative (Alternative (..))+import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, Sized (..), traceHG)+import Proarrow.Category.Monoidal.Strictified+  ( Fold+  , Strictified (..)+  , concatMany+  , obj1+  , singleton+  , splitMany+  , swap2+  , withIsListOf+  , withObFold+  , type (++)+  )+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Colimit.Pushout (HasPushouts (..))+import Proarrow.Core (CategoryOf (..), Kind, OB, Ob', Profunctor, Promonad (..), UN, (//))+import Proarrow.Functor (Functor (..))+import Proarrow.Monoid (comultS, counitS, mappendS, memptyS)+import Proarrow.Object+  ( KnownListOf (..)+  , ListOf (..)+  , SomeOf (..)+  , appendListOf+  , lengthListOf+  , someOfList+  , withKnownListOf+  , withListOf+  )+import Proarrow.Optic.Iso (DecidableIso (..), withIso)++-- * 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 = lineUp (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 = \(Port i) -> table M.! i+  where+    table = M.fromList (P.zip [0 ..] (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 = listOf++-- | The sorts of the list, one by one.+sortList :: forall s (xs :: [s]). (SortList xs) => [SomeSort s]+sortList = someOfList (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 (P.Eq, P.Ord, P.Show)++instance (SortList (xs :: [s])) => Universe (Port xs) where+  universe = P.fmap Port [0 .. lengthListOf (sorts @s @xs) P.- 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 ss k = withListOf ss \ @xs l -> withKnownListOf l (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 = Sub (FinHask 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 @a @b r = withKnownListOf (appendListOf (sorts @s @(PortSorts @s (UN SUB a))) (sorts @s @(PortSorts @s (UN SUB b)))) r+  lft @a @b =+    withObCoprod @(SORTED s) @a @b+      (Sub (FinHask (M.fromList [(Port i, Port i) | Port i <- universeF @(Port (PortSorts @s (UN SUB a)))])))+  rgt @a @b =+    withObCoprod @(SORTED s) @a @b+      ( Sub+          ( FinHask+              ( M.fromList+                  [ (Port j, Port (lengthListOf (sorts @s @(PortSorts @s (UN SUB a))) P.+ j))+                  | Port j <- universeF @(Port (PortSorts @s (UN SUB b)))+                  ]+              )+          )+      )+  (|||) @x @_ @y (Sub (FinHask f)) (Sub (FinHask g)) =+    withObCoprod @(SORTED s) @x @y P.$+      Sub+        ( FinHask+            (M.fromList ([(Port i, x) | (Port i, x) <- M.toList f] P.++ [(Port (M.size f P.+ j), x) | (Port j, x) <- M.toList 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 (Sub @_ @_ @a f) (Sub @_ @_ @b g) k = pushout f g \(FinHask l) (FinHask r) ->+    let+      sortA = sortOf @s @a+      sortB = sortOf @s @b+      nodeSorts = M.fromList ([(p, sortA x) | (x, p) <- M.toList l] P.++ [(p, sortB y) | (y, p) <- M.toList r])+      nodes = M.keys nodeSorts+    in+      reifySorts (M.elems nodeSorts) \ @xs ->+        let renumber = M.fromList (P.zip nodes (P.fmap Port [0 ..]))+        in k (Sub (FinHask @_ @(Port xs) (P.fmap (renumber M.!) l))) (Sub (FinHask (P.fmap (renumber M.!) r)))+  factorPushout (Sub p1) (Sub p2) (Sub k1) (Sub k2) = Sub (factorPushout p1 p2 k1 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 {label :: l, inputs :: [n], outputs :: [n]}+  deriving (P.Eq, P.Ord, P.Show, 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 (Sub (FinHask m)) (Boxes bs) = Boxes (P.fmap (P.fmap (m M.!)) 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 () = Boxes []+  alt @a h (Boxes xs, Boxes ys) =+    map h (Boxes (P.fmap (P.fmap (\(Port i) -> Port i)) xs P.++ P.fmap (P.fmap (\(Port j) -> Port (offset P.+ j))) ys))+    where+      offset = lengthListOf (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 x =+  withObCoprod @(SORTED s) @(SUB (FH (Port as))) @(SUB (FH (Port bs)))+    ( DecCospan+        (lft @_ @(SUB (FH (Port as))) @(SUB (FH (Port bs))))+        (rgt @_ @(SUB (FH (Port as))) @(SUB (FH (Port bs))))+        (Boxes [Box x (P.take na ports) (P.drop na ports)])+    )+  where+    na = lengthListOf (sorts @s @as)+    ports = P.fmap Port [0 .. na P.+ lengthListOf (sorts @s @bs) P.- 1]++-- | The open hypergraph with nodes of the given sorts, the wires of @as@ and of @bs@ attached to+-- the given nodes, and boxes on the given nodes, numbered from 0. Fails with a message unless every+-- wire has a sort isomorphic to that of its node and every node exists.+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 nodeSorts ins outs boxList+  | P.length ins P./= lengthListOf (sorts @s @as) P.|| P.length outs P./= lengthListOf (sorts @s @bs) =+      P.Left "openHypergraph: a boundary has a different number of wires than its sorts"+  | P.any+      (`M.notMember` sortAt)+      (ins P.++ outs P.++ P.concat [inputs bx P.++ outputs bx | bx <- boxList]) =+      P.Left "openHypergraph: a wire or box is attached to a node that does not exist"+  | P.not+      ( lineUpAll byIso (P.fmap (sortAt M.!) ins) (sortList @s @as)+          P.&& lineUpAll byIso (P.fmap (sortAt M.!) outs) (sortList @s @bs)+      ) =+      P.Left "openHypergraph: a wire does not have the sort of its node"+  | P.otherwise = P.Right (unsafeOpenHypergraph nodeSorts ins outs boxList)+  where+    sortAt = M.fromList (P.zip [0 ..] nodeSorts)++-- | 'openHypergraph' without its checks: 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 nodeSorts ins outs boxList = reifySorts nodeSorts \ @ns ->+  DecCospan+    (Sub (FinHask (M.fromList (P.zip universeF (P.fmap (Port @_ @ns) ins)))))+    (Sub (FinHask (M.fromList (P.zip universeF (P.fmap (Port @_ @ns) outs)))))+    (Boxes (P.fmap (P.fmap Port) boxList))++-- | 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+  (DecCospan @c1 (Sub (FinHask l1)) (Sub (FinHask r1)) (Boxes bs1))+  (DecCospan @c2 (Sub (FinHask l2)) (Sub (FinHask r2)) (Boxes bs2)) =+    -- the nodes that nothing is attached to can be matched up exactly when this holds+    sameBag sameSort (P.fmap sort1 nodes1) (P.fmap sort2 nodes2)+      P.&& sameBag (P.==) (P.fmap shape bs1) (P.fmap shape bs2)+      P.&& isJust+        (extendAll (M.empty, M.empty) (P.zip (M.elems l1) (M.elems l2) P.++ P.zip (M.elems r1) (M.elems r2)) P.>>= boxes bs1 bs2)+    where+      nodes1 = universeF @(UN FH (UN SUB c1))+      nodes2 = universeF @(UN FH (UN SUB c2))+      sort1 = sortOf @s @(UN SUB c1)+      sort2 = sortOf @s @(UN SUB c2)+      shape (Box x i o) = (x, P.length i, P.length o)+      -- the same elements, counted with multiplicity+      sameBag _ [] ys = P.null ys+      sameBag eq (x : xs) ys = case List.break (eq x) ys of+        (_, []) -> P.False+        (before, _ : after) -> sameBag eq xs (before P.++ after)+      boxes [] _ m = P.Just m+      boxes (x : xs) ys m = msum [match x y m P.>>= boxes xs rest | (y, rest) <- picks ys]+      match (Box lx ix ox) (Box ly iy oy) m+        | lx P.== ly P.&& P.length ix P.== P.length iy P.&& P.length ox P.== P.length oy =+            extendAll m (P.zip ix iy P.++ P.zip ox oy)+        | P.otherwise = P.Nothing+      extendAll = foldM (P.flip extend)+      extend (x, y) (fwd, bwd)+        | P.not (sameSort (sort1 x) (sort2 y)) = P.Nothing+        | P.otherwise = case (M.lookup x fwd, M.lookup y bwd) of+            (P.Nothing, P.Nothing) -> P.Just (M.insert x y fwd, M.insert y x bwd)+            (P.Just y', P.Just x') | y' P.== y P.&& x' P.== x -> P.Just (fwd, bwd)+            _ -> P.Nothing+      picks :: [x] -> [(x, [x])]+      picks xs = [(x, before P.++ after) | (before, x : after) <- P.zip (List.inits xs) (List.tails 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 = SomeArrow (sorts @s @as) (sorts @s @bs)++-- | The term of a hypergraph category that an open hypergraph stands for, given an arrow for each+-- label: 'readBackWith' with the sizes from 'Sized'.+readBack+  :: forall {s} l a b+   . (Hypergraph s, Sized s, DecidableIso s)+  => (l -> SomeArrow s)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (WireSorts a ~> WireSorts b)+readBack = readBackWith (sizeFromSized @s)++-- | The term of a hypergraph category that an open hypergraph stands for, given the size of each+-- sort and an arrow for each label. A box first merges its own wires of one node and discards those+-- that nothing else needs, and a node is merged as soon as nothing still to come needs it. The order+-- is numpy's greedy one, which takes the contraction whose result grows least, its size less the+-- sizes of the two parts. The boxes without inputs are contracted with each other first, as a tree+-- of pairs that share a node, so a network of tensors is read back as its contraction tree. The+-- pieces and the other boxes then follow the flow of their wires one at a time, with between two+-- boxes one spider per node. A node that a box uses no later than a box makes it is fed back with+-- a trace, which only a cyclic hypergraph needs. Fails with a message when an arrow does not fit+-- its box. An arrow whose sorts are isomorphic to those of its box is moved along the+-- isomorphisms.+readBackWith+  :: forall {s} l a b+   . (Hypergraph s, DecidableIso s)+  => (SomeSort s -> P.Int)+  -> (l -> SomeArrow s)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (WireSorts a ~> WireSorts b)+readBackWith = readBackAligned (byIso @s)++-- | The read-back, with the sorts lined up by the given alignment.+readBackAligned+  :: forall {s} l a b+   . (Hypergraph s)+  => Align s+  -> (SomeSort s -> P.Int)+  -> (l -> SomeArrow s)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (WireSorts a ~> WireSorts b)+readBackAligned al sizeFn interp hg@(DecCospan @c (Sub (FinHask legIn)) (Sub (FinHask legOut)) (Boxes boxList)) =+  hg // do+    arrows0 <- M.fromList P.<$> P.traverse interpBox labelled+    let arrows = M.union arrows0 (M.fromList [(j, pieceArrow al nodeSort arrows0 t) | (j, t) <- merged])+    P.pure P.$ withListOf (P.fmap (nodeSort P.. KN) (feedback lt)) \fb ->+      let insS = sorts @s @(WireSorts a)+          outsS = sorts @s @(WireSorts b)+          start = appendListOf fb insS+          (bundle, body) =+            P.foldl+              (step al nodeSort lt arrows)+              (P.fmap KN (feedback lt P.++ shapeIns shape), Built start Same)+              (P.zip [1 ..] order)+          final =+            transition+              al+              nodeSort+              (isolated shape boxes0)+              bundle+              (P.fmap KL (feedback lt) P.++ P.fmap (outKey lt) (shapeOuts shape))+              body+      in case final of+           Built ys whole -> case alignSteps al ys (appendListOf fb outsS) of+             P.Just to -> traceSorts fb insS outsS (arrowOf ys to . arrowOf start whole)+             P.Nothing -> P.error "readBack: the boundaries were planned with other sorts"+  where+    nodes = universeF @(UN FH (UN SUB c))+    index = M.fromList (P.zip nodes [0 :: P.Int ..])+    sortC = sortOf @s @(UN SUB c)+    sortAt = M.fromList [(index M.! n, sortC n) | n <- nodes]+    nodeSort k = sortAt M.! keyNode k+    labelled = P.zip [0 :: P.Int ..] [P.fmap (index M.!) bx | bx <- boxList]+    shape =+      Shape+        { shapeNodes = M.elems index+        , shapeIns = P.fmap (index M.!) (M.elems legIn)+        , shapeOuts = P.fmap (index M.!) (M.elems legOut)+        }+    boxes0 = [(i, bx{label = ()}) | (i, bx) <- labelled]+    size ns = P.product [P.fromIntegral (sizeFn (sortAt M.! n)) :: P.Double | n <- Set.toList ns]+    (boxesIx, merged) = pathBoxes boxes0 (contractStates size shape boxes0)+    order = schedule size shape boxesIx+    lt = lifetimes shape boxesIx order+    interpBox (i, Box x is os) = case interp x of+      arr@(SomeArrow xs ys _)+        | lineUpAll al (someOfList xs) (nodeSorts is) P.&& lineUpAll al (someOfList ys) (nodeSorts os) -> P.Right (i, arr)+        | P.otherwise -> P.Left "readBack: the arrow of a label does not have the sorts of its box"+    nodeSorts = P.fmap (nodeSort P.. KN)++-- ** Planning++-- | The nodes of an open hypergraph, numbered from 0, and its boundaries.+data Shape = Shape {shapeNodes :: [P.Int], shapeIns :: [P.Int], shapeOuts :: [P.Int]}++-- | A numbered box.+type Ix = (P.Int, Box () P.Int)++touches :: Ix -> Set.Set P.Int+touches (_, bx) = Set.fromList (inputs bx P.++ outputs bx)++without :: Ix -> [Ix] -> [Ix]+without bx = P.filter (\b -> P.fst b P./= P.fst bx)++-- | The nodes that the given boxes or the outputs need.+neededBy :: Shape -> [Ix] -> Set.Set P.Int+neededBy sh rest = Set.unions (Set.fromList (shapeOuts sh) : [touches b | b <- 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 sh placed rest = Set.intersection (Set.union (Set.fromList (shapeIns sh)) placed) (neededBy sh 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 sh bxs bx = Set.intersection (touches bx) (Set.union (Set.fromList (shapeIns sh)) (neededBy sh (without bx 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 size whole a b = size whole P.- size a P.- size b++-- | Some of the boxes without inputs, contracted as a tree, with how many of them touch each node and+-- the nodes something outside them needs.+data Piece = Piece {pieceTree :: Tree, pieceCounts :: M.Map P.Int P.Int, pieceOpen :: Set.Set P.Int}++-- | The boxes without inputs contracted with each other as a tree, in numpy's greedy order: the pair+-- that shares a node and whose result grows least, until no two share a node.+contractStates :: (Set.Set P.Int -> P.Double) -> Shape -> [Ix] -> [Piece]+contractStates size sh bxs = contract [leaf b | b@(_, bx) <- bxs, P.null (inputs bx)]+  where+    -- 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 =+      M.fromListWith+        (P.+)+        ([(n, 1) | b <- bxs, n <- Set.toList (touches b)] P.++ [(n, 1) | n <- nubOrd (shapeIns sh P.++ shapeOuts sh)])+    openIn counts = Set.fromList [n | (n, c) <- M.toList counts, c P.< total M.! n]+    keysIn open made = [k | k <- nubOrd made, keyNode k `Set.member` open]+    leaf b@(i, bx) =+      let counts = M.fromList [(n, 1) | n <- Set.toList (touches b)]+          open = openIn counts+      in Piece (Leaf i (P.fmap KN (outputs bx)) (keysIn open (P.fmap KN (outputs bx)))) counts open+    merge a b =+      let counts = M.unionWith (P.+) (pieceCounts a) (pieceCounts b)+          open = openIn counts+      in Piece (Merge (pieceTree a) (pieceTree b) (keysIn open (treeKeys (pieceTree a) P.++ treeKeys (pieceTree b)))) counts open+    contract ps =+      case [ (gain size (pieceOpen ab) (pieceOpen a) (pieceOpen b), a, b, ab)+           | a : rest <- List.tails ps+           , b <- rest+           , P.not (Set.disjoint (pieceOpen a) (pieceOpen b))+           , let ab = merge a b+           ] of+        [] -> ps+        cs ->+          let (_, a, b, ab) = List.minimumBy (comparing (\(c, _, _, _) -> c)) cs+          in contract [if pieceTree q P.== pieceTree a then ab else q | q <- ps, pieceTree q P./= pieceTree b]++-- | 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 bxs pieces =+  ( [b | b@(i, bx) <- bxs, P.not (P.null (inputs bx)) P.|| i `P.elem` alone']+      P.++ [(j, Box () [] (P.fmap keyNode (treeKeys t))) | (j, t) <- merged]+  , merged+  )+  where+    alone' = [i | Piece{pieceTree = Leaf i _ _} <- pieces]+    merged = [(j, t) | (j, Piece{pieceTree = t@Merge{}}) <- P.zip [P.length bxs ..] 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 size sh bxs = go Set.empty bxs+  where+    go _ [] = []+    go placed remaining =+      let open = openAfter sh placed remaining+          after bx = openAfter sh (Set.union placed (touches bx)) (without bx remaining)+          cost bx = gain size (after bx) open (alone sh bxs bx)+          pairCost (x, y) =+            gain+              size+              (openAfter sh (Set.union placed (Set.union (touches x) (touches y))) (without y (without x remaining)))+              (alone sh bxs x)+              (alone sh bxs y)+          next+            | Set.null open+            , _ : _ : _ <- remaining =+                P.fst (List.minimumBy (comparing pairCost) [(x, y) | x <- candidates remaining, y <- candidates (without x remaining)])+            | P.otherwise = List.minimumBy (comparing cost) (candidates remaining)+      in next : go (Set.union placed (touches next)) (without next remaining)+    candidates remaining = case [bx | bx <- remaining, P.not (P.any (dependsOn bx) remaining)] of+      [] -> P.take 1 remaining+      ready -> ready+    -- a box depends on another when it uses a node the other makes+    dependsOn (i, bi) (j, bj) = i P./= j P.&& P.any (`P.elem` outputs bj) (inputs bi)++-- | When the wires of the read-back are needed, for the boxes in the given order.+data Lifetimes = Lifetimes+  { feedback :: [P.Int]+  -- ^ the nodes that a box uses no later than a box makes them, fed back with a trace+  , outKey :: P.Int -> Key+  -- ^ the wire that a box makes of a node+  , 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 sh bxs order = Lifetimes{feedback = fb, outKey = key, live = alive}+  where+    layerOf = M.fromList (P.zip (P.fmap P.fst order) [1 :: P.Int ..])+    madeAt = M.fromListWith (P.++) [(n, [layerOf M.! i]) | (i, bx) <- bxs, n <- outputs bx]+    usedAt = M.fromListWith (P.++) [(n, [layerOf M.! i]) | (i, bx) <- bxs, n <- inputs bx]+    layersOf n m = M.findWithDefault [] n m+    fb = [n | n <- shapeNodes sh, P.or [mk P.>= u | u <- layersOf n usedAt, mk <- layersOf n madeAt]]+    key n = if n `P.elem` fb then KL n else KN n+    alive t (KN n)+      | n `P.elem` fb = P.any (P.> t) (layersOf n usedAt)+      | P.otherwise = P.any (P.> t) (layersOf n usedAt P.++ layersOf n madeAt) P.|| n `P.elem` shapeOuts sh+    alive _ (KL _) = 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 sh bxs = [KN n | n <- shapeNodes sh, n `Set.notMember` attached]+  where+    attached = Set.fromList (shapeIns sh P.++ shapeOuts sh P.++ P.concat [inputs bx P.++ outputs bx | (_, bx) <- 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. (Hypergraph s) => Align s -> (Key -> SomeSort s) -> M.Map P.Int (SomeArrow s) -> Tree -> SomeArrow s+pieceArrow al nodeSort arrows0 t0 = case go t0 of+  Built ys f -> SomeArrow Nil ys (arrowOf Nil f)+  where+    go :: Tree -> Built ('[] :: [s])+    go t = transition al nodeSort [] (treeMade t) (treeKeys t) (body t)+    body (Leaf i _ _) = boxThen al (arrows0 M.! i) Nil+    body (Merge l r _) = beside Nil (go l) Nil (go r)++-- | One box placed after the wires that go past it, between the spiders before and after it.+step+  :: forall s (xs :: [s])+   . (Hypergraph s)+  => Align s+  -> (Key -> SomeSort s)+  -> Lifetimes+  -> M.Map P.Int (SomeArrow s)+  -> ([Key], Built xs)+  -> (P.Int, Ix)+  -> ([Key], Built xs)+step al nodeSort lt arrows (bundle, body) (t, (i, bx)) =+  let need = P.fmap KN (inputs bx)+      made = P.fmap (outKey lt) (outputs bx)+      -- a wire goes past the box when it is needed after it or is merged with a wire across it:+      -- the carried wires, and what is left of the box, its wires of one node merged+      carry = [k | k <- nubOrd (bundle P.++ need), live lt t k P.|| k `P.elem` made]+      kept = [k | k <- nubOrd made, live lt t k P.|| k `P.elem` carry]+      -- the box goes after the carried wires, next to the wires it is merged with later+      run :: forall (ws :: [s]). Sorts ws -> Built ws+      run ws = splitSorts (P.length carry) ws \pre post ->+        beside pre (Built pre Same) post (transition al nodeSort [] made kept (boxThen al (arrows M.! i) post))+  in ( carry P.++ kept+     , run `afterBuilt` transition al nodeSort [] bundle (carry P.++ need) body+     )++-- | 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])+   . (Hypergraph s) => Align s -> (Key -> SomeSort s) -> [Key] -> [Key] -> [Key] -> Built xs -> Built xs+transition al nodeSort extra from to built =+  let present = nubOrd (from P.++ to)+      kinds = groupOrder from to present P.++ [k | k <- extra, k `P.notElem` present]+      count k ks = P.length (P.filter (P.== k) ks)+      identity = P.all (\k -> count k from P.== 1 P.&& count k to P.== 1) kinds+      spiders :: forall (ws :: [s]). Sorts ws -> Built ws+      spiders ws+        | identity = Built ws Same+        | P.otherwise = spidersThen al [(nodeSort k, count k from, count k to) | k <- kinds] ws+  in permuteThen (inverse (positionsIn kinds to)) (spiders `afterBuilt` permuteThen (positionsIn kinds from) built)+  where+    inverse p = P.fmap P.snd (List.sort (P.zip p [0 :: P.Int ..]))++-- | The positions of the wires in the order that groups them by kind.+positionsIn :: [Key] -> [Key] -> [P.Int]+positionsIn kinds ks = [i | k <- kinds, i <- [j | (j, k') <- P.zip [0 :: P.Int ..] ks, k' P.== 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 from to present+  | P.length present P.<= 6 = List.minimumBy (comparing cost) (List.permutations present)+  | P.otherwise = List.sortOn average present+  where+    crossings ks = M.fromListWith (P.+) [((a, b), 1 :: P.Int) | (j, a) <- P.zip [0 :: P.Int ..] ks, b <- P.take j ks, a P./= b]+    weighed = M.unionWith (P.+) (P.fmap (P.* P.length from) (crossings from)) (P.fmap (P.* P.length to) (crossings to))+    -- each pair of kinds in the wrong order costs its wires that cross+    cost kinds = P.sum [M.findWithDefault 0 (a, b) weighed | (j, b) <- P.zip [0 :: P.Int ..] kinds, a <- P.take j kinds]+    average k =+      let is = [i | (i, k') <- P.zip [0 :: P.Int ..] (from P.++ to), k' P.== k]+      in P.fromIntegral (P.sum is) P./ (P.fromIntegral (P.length 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 f = box (Prim (someArrow f))++-- | 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 = Prim++-- | The term of @k@ that a term run in 'SIMPLIFY' stands for: its read-back, with each box the+-- arrow it was made from, and the sizes from 'Sized'.+simplify :: forall {k} a b. (Hypergraph k, Sized k) => (a :: SIMPLIFY k) ~> b -> WireSorts a ~> WireSorts b+simplify = simplifyWith (sizeFromSized @k)++-- | 'simplify' with the given sizes. The sorts of a box are those of its arrow, so they need not be+-- compared.+simplifyWith+  :: forall {k} a b. (Hypergraph k) => (SomeSort k -> P.Int) -> (a :: SIMPLIFY k) ~> b -> WireSorts a ~> WireSorts b+simplifyWith sizeFn t = case readBackAligned trusted sizeFn (\(Prim a) -> a) t of+  P.Right r -> r+  P.Left e -> P.error e++-- | The size of a sort, from 'Sized'.+sizeFromSized :: forall s. (Sized s) => SomeSort s -> P.Int+sizeFromSized (Some @x) = 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 @_ @x @y = P.fmap (\o -> withIso @Profunctor o \f _ -> Arrow (singleton f)) (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 @_ @x @y = P.Just (unsafeCoerce (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 (P.Eq)++treeKeys :: Tree -> [Key]+treeKeys (Leaf _ _ ks) = ks+treeKeys (Merge _ _ ks) = ks++-- | The wires that come into the last step of a piece.+treeMade :: Tree -> [Key]+treeMade (Leaf _ made _) = made+treeMade (Merge l r _) = treeKeys l P.++ treeKeys 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 (P.Eq, P.Ord)++keyNode :: Key -> P.Int+keyNode (KN n) = n+keyNode (KL n) = 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 k (Built ys f) = case k ys of+  Built zs g -> Built zs (compose g f)+  where+    compose Same h = h+    compose h Same = h+    compose (Arrow q) (Arrow p) = Arrow (q . p)++arrowOf :: (Monoidal s) => Sorts (xs :: [s]) -> Step xs ys -> xs ~> ys+arrowOf xs Same = withIsListOf xs id+arrowOf _ (Arrow f) = f++-- | Two built pieces side by side.+beside :: (Monoidal s) => Sorts (xs :: [s]) -> Built xs -> Sorts xs' -> Built xs' -> Built (xs ++ xs')+beside xs (Built ys f) xs' (Built ys' g) = Built (appendListOf ys ys') (besideStep xs f xs' 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 _ Same _ Same = Same+besideStep xs f xs' g = Arrow (arrowOf xs f ** arrowOf xs' 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 0 xs k = k Nil xs+splitSorts n (Cons @x rest) k = splitSorts (n P.- 1) rest \pre post -> k (Cons @x pre) post+splitSorts _ Nil _ = P.error "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 al (Some @x) (Some @y) = isJust (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 al xs ys = P.length xs P.== P.length ys P.&& P.and (P.zipWith (lineUp al) xs 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 _ Nil Nil = P.Just Same+alignSteps al (Cons @x xs) (Cons @y ys) = do+  a <- al @x @y+  rest <- alignSteps al xs ys+  P.pure (besideStep (single @x) a xs rest)+alignSteps _ _ _ = P.Nothing++single :: forall {s} (x :: s). (Ob' x) => Sorts '[x]+single = Cons @x Nil++-- | 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 al (SomeArrow as bs f) xs = splitSorts (lengthListOf as) xs \pre post -> case alignSteps al pre as of+  P.Just into -> beside pre (Built bs (Arrow (f . arrowOf pre into))) post (Built post Same)+  P.Nothing -> P.error "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 :: (Hypergraph s) => [P.Int] -> Built (xs :: [s]) -> Built xs+permuteThen p built0 = P.foldl (\built i -> swapThen i `afterBuilt` built) built0 (P.reverse (bubble p []))+  where+    -- the positions of the adjacent swaps that sort @p@+    bubble ps acc = case [i | (i, (a, b)) <- P.zip [0 ..] (P.zip ps (P.drop 1 ps)), a P.> b] of+      [] -> P.reverse acc+      i : _ -> bubble (P.take i ps P.++ [ps P.!! (i P.+ 1), ps P.!! i] P.++ P.drop (i P.+ 2) ps) (i : acc)++-- | The swap of the wires at positions @i@ and @i + 1@.+swapThen :: (Hypergraph s) => P.Int -> Sorts (xs :: [s]) -> Built xs+swapThen 0 (Cons @x (Cons @y rest)) = Built (Cons @y (Cons @x rest)) (Arrow (swap2 @x @y ** withIsListOf rest id))+swapThen i (Cons @x rest) = case swapThen (i P.- 1) rest of+  Built ys f -> Built (Cons @x ys) (Arrow (obj1 @x ** arrowOf rest f))+swapThen _ Nil = P.error "readBack: a swap beyond the wires was planned"++-- | For each sort, a spider from the given number of wires to the given number.+spidersThen :: (Hypergraph s) => Align s -> [(SomeSort s, P.Int, P.Int)] -> Sorts (xs :: [s]) -> Built xs+spidersThen _ [] Nil = Built Nil Same+spidersThen _ [] _ = P.error "readBack: wires without a spider were planned"+spidersThen al ((x, c, m) : rest) xs = splitSorts c xs \pre post -> beside pre (spider al x c m pre) post (spidersThen al rest post)++-- | The spider of a sort from @c@ wires to @m@: merging all of them, then copying the result.+spider :: (Hypergraph s) => Align s -> SomeSort s -> P.Int -> P.Int -> Sorts (pre :: [s]) -> Built pre+spider al (Some @x) c m pre+  | c P.== 1 P.&& m P.== 1 = Built pre Same+  | P.otherwise = case copies @x m of Built ys f -> Built ys (Arrow (arrowOf (single @x) f . merges @x al 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. (Hypergraph s, Ob x) => Align s -> Sorts pre -> pre ~> '[x]+merges _ Nil = memptyS @x+merges al (Cons @y Nil) = toX @y al+merges al (Cons @y rest@Cons{}) = mappendS @x . (toX @y al ** merges @x al rest)++toX :: forall {s} y (x :: s). (Monoidal s, Ob x, Ob y) => Align s -> '[y] ~> '[x]+toX al = case al @y @x of+  P.Just a -> arrowOf (single @y) a+  P.Nothing -> P.error "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). (Hypergraph s, Ob x) => P.Int -> Built '[x]+copies 0 = Built Nil (Arrow (counitS @x))+copies 1 = Built (single @x) Same+copies 2 = Built (Cons @x (single @x)) (Arrow (comultS @x))+copies m = case copies @x (m P.- 1) of+  Built ys f -> Built (Cons @x ys) (Arrow ((obj1 @x ** arrowOf (single @x) f) . comultS @x))++-- | The trace over the first wires, @us@, which feeds their outputs back to their inputs.+traceSorts+  :: forall {s} (us :: [s]) xs ys+   . (Hypergraph s)+  => Sorts us+  -> Sorts xs+  -> Sorts ys+  -> (us ++ xs) ~> (us ++ ys)+  -> xs ~> ys+traceSorts Nil _ _ f = f+traceSorts us xs ys f =+  withIsListOf us P.$+    withIsListOf xs P.$+      withIsListOf ys P.$+        withObFold @us P.$+          withObFold @xs P.$+            withObFold @ys P.$+              splitMany @ys+                . Str+                  ( traceHG @(Fold us) @(Fold xs) @(Fold ys)+                      (unStr ((concatMany @us ** concatMany @ys) . f . (splitMany @us ** splitMany @xs)))+                  )+                . concatMany @xs
src/Proarrow/Category/Instance/Ordinal.hs view
@@ -16,7 +16,7 @@   , Finite (..)   , FmapWrap   , Indexed (..)-  , IndexedList (..)+  , IndexedList   , Lookup   , MapWrap   , ThinProfunctor (..)@@ -50,6 +50,7 @@ import Proarrow.Limit.Pullback (HasPullbacks (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..)) import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Object (ListOf (..)) import Prelude qualified as P  type data ORDINAL n where@@ -138,12 +139,12 @@   => SNat i -> ((Lookup (OrdObjects n) i ~ OrdAt n i) => IndexedList (OrdObjects n) -> r) -> r withOrdObjects i k =   ordSize @n-    (k FNil)-    (case i of SZ -> k (FCons FNil); SS -> k (FCons FNil))+    (k Nil)+    (case i of SZ -> k (Cons Nil); SS -> k (Cons Nil))     ( \ @m -> case i of-        SZ -> withOrdObjects @(S m) SZ \xs -> k (FCons (mapWrap @OS xs))+        SZ -> withOrdObjects @(S m) SZ \xs -> k (Cons (mapWrap @OS xs))         SS @i' -> withOrdObjects @(S m) (snat @i') \xs ->-          withLookupMapWrap @OS (snat @i') xs (k (FCons (mapWrap @OS xs)))+          withLookupMapWrap @OS (snat @i') xs (k (Cons (mapWrap @OS xs)))     )  -- | The ordinal at an index, if there is one. 'Enumerable' cannot go through the generic 'atOb',
+ src/Proarrow/Category/Instance/TensorNetwork.hs view
@@ -0,0 +1,634 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE NoStarIsType #-}++-- | __Tensor networks__ as a hypergraph category: the same arrows as the matrices of+-- "Proarrow.Category.Instance.Mat", kept as a network instead of as one matrix. An object is a list+-- of dimensions, one for each wire. An arrow has nodes, each with a dimension, a node for each of its+-- input and output wires, and dense factors: flat vectors, each with a node for each of its axes. Its+-- entry at given indices of the wires is the sum, over the indices of the nodes that agree with+-- those of the wires, of the products of the entries of the factors.+--+-- So the structure of a hypergraph category costs nothing: identities, swaps, copying, merging,+-- discarding, cups and caps are wirings without factors, and the tensor puts factors side by side+-- without multiplying them. Composition glues the wirings and sums out the nodes that are no longer+-- on a wire, multiplying only the factors that a summed node joins. With "Proarrow.Tools.Einsum" a+-- network of tensors is contracted in the order its read-back chooses.+--+-- With the package's @blas@ flag, a contraction of two factors that is a matrix product is handed+-- to the system's BLAS (Accelerate on macOS, OpenBLAS elsewhere) at entries of type 'P.Double',+-- 'P.Float' and @'Complex' 'P.Double'@.+--+-- The biproducts are direct sums, a single wire whose dimension is the sum of the sizes of the two+-- objects. Their injections, projections and pairings are dense matrices, and so are the+-- distributors.+module Proarrow.Category.Instance.TensorNetwork+  ( TNET (..)+  , TensorNetwork+  , Scalar+  , dimsOf+  , Size+  , fromVector+  , toVector+  , fromEntries+  , entries+  ) where++import Data.Complex (Complex, conjugate)+import Data.Containers.ListUtils (nubOrd)+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.Kind (Constraint, Type)+import Data.List qualified as List+import Data.Ord (comparing)+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import Data.Type.Equality ((:~:) (..))+import Data.Vector.Storable qualified as SV+import Data.Vector.Storable.Mutable qualified as MSV+import Data.Vector.Unboxed qualified as UV+import Foreign.Storable (Storable)+import GHC.TypeNats (KnownNat, Nat, SNat, natVal, sameNat, withKnownNat, withSomeSNat, type (*), type (+))+import Unsafe.Coerce (unsafeCoerce)+import Prelude (Int, ($), (*), (+), (-), (==))+import Prelude qualified as P++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.FinHask (unionFind)+import Proarrow.Category.Instance.TensorNetwork.Blas (Gemm, gemmComplexDouble, gemmDouble, gemmFloat)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cap, cup)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), HasBiproducts)+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, type (+->))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Object (KnownListOf (..), appendListOf, eqListOf, mapListOf, withKnownListOf, type (++))+import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality)++-- | The entries of the factors: numbers that can be stored unboxed. An instance needs no methods:+-- the loop that contracts factors is then compiled for its type.+type Scalar :: Type -> Constraint+class (P.Num e, Storable e) => Scalar e where+  -- | The entries of a contraction of two factors: given the dimension of each axis of the result+  -- and how far a step along it moves in the entries of each factor, the offset into each factor+  -- of each summed index, and the entries of the two factors, each entry is a sum of products.+  kernel :: [(Dim, Int, Int)] -> UV.Vector Index -> UV.Vector Index -> SV.Vector e -> SV.Vector e -> SV.Vector e+  -- inlined into each instance, so that the loop is specialised to its type+  kernel = contractLoop+  {-# INLINE kernel #-}++  -- | The conjugate of an entry, which the dagger takes: the identity on real numbers.+  conj :: e -> e+  conj = P.id++  -- | A fast matrix product, which a contraction of two factors that is one is handed to.+  gemm :: P.Maybe (Gemm e)+  gemm = P.Nothing++instance Scalar Int+instance Scalar P.Double where+  gemm = gemmDouble+instance Scalar P.Float where+  gemm = gemmFloat+instance Scalar (Complex P.Double) where+  conj = conjugate+  gemm = gemmComplexDouble++-- | The loop that 'kernel' runs, written once for every type: a loop over each axis of the result,+-- the last one innermost, reading the entries of both factors with their steps, and for each+-- entry a loop over the summed indices.+{-# INLINEABLE contractLoop #-}+contractLoop+  :: (P.Num e, Storable e)+  => [(Dim, Int, Int)] -> UV.Vector Index -> UV.Vector Index -> SV.Vector e -> SV.Vector e -> SV.Vector e+contractLoop steps !so !to !v !w = SV.create do+  out <- MSV.unsafeNew (P.product [d | (d, _, _) <- steps])+  let go [] !a !b !dst = MSV.unsafeWrite out dst (entry a b)+      go [(!d, !s, !t)] !a !b !dst+        | n == 1 = products 0 (a + so `UV.unsafeIndex` 0) (b + to `UV.unsafeIndex` 0)+        | P.otherwise = sums 0 a b+        where+          -- with nothing summed, each entry is one product+          products !i !x !y+            | i == d = P.pure ()+            | P.otherwise =+                MSV.unsafeWrite out (dst + i) (v `SV.unsafeIndex` x * w `SV.unsafeIndex` y) P.>> products (i + 1) (x + s) (y + t)+          sums !i !x !y+            | i == d = P.pure ()+            | P.otherwise = MSV.unsafeWrite out (dst + i) (entry x y) P.>> sums (i + 1) (x + s) (y + t)+      go ((!d, !s, !t) : rest) !a !b !dst = outer 0 a b+        where+          size' = P.product [e | (e, _, _) <- rest]+          outer !i !x !y+            | i == d = P.pure ()+            | P.otherwise = go rest x y (dst + i * size') P.>> outer (i + 1) (x + s) (y + t)+  go steps 0 0 0+  P.pure out+  where+    n = UV.length so+    -- the sum of the products at a place in each factor; its arguments are strict, so that the loop+    -- does not look them up again for every index+    entry !a !b = sumFrom 0 0+      where+        sumFrom !i !acc =+          if i == n+            then acc+            else+              sumFrom (i + 1) (acc + v `SV.unsafeIndex` (a + so `UV.unsafeIndex` i) * w `SV.unsafeIndex` (b + to `UV.unsafeIndex` i))++-- | A node of a network, numbered from 0.+type Node = Int++-- | The dimension of a wire or a node.+type Dim = Int++-- | An index along a wire or an axis, or a position in a factor's entries.+type Index = Int++-- | Objects are lists of dimensions, one for each wire.+type data TNET (e :: Type) = TN [Nat]++-- | The dimensions of a list, as numbers.+dimsOf :: forall ns. (KnownListOf KnownNat ns) => [Dim]+dimsOf = mapListOf @KnownNat (\ @n -> P.fromIntegral (natVal (Proxy @n))) (listOf @KnownNat @ns)++-- | A dense factor: its entries, row by row over its axes, and the node of each axis.+data Factor e = Factor {axes :: [Node], values :: SV.Vector e}++-- | The nodes, numbered from 0 with their dimensions, the node of each input and output wire, and+-- the factors. Kept so that every node is on a wire and no factor has an axis twice.+data Net e = Net {nodeDims :: [Dim], ins :: [Node], outs :: [Node], factors :: [Factor e]}++-- | An arrow between two lists of dimensions.+type TensorNetwork :: CAT (TNET e)+data TensorNetwork a b where+  TensorNetwork+    :: forall {e} as bs. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => Net e -> TensorNetwork (TN as :: TNET e) (TN bs)++-- | A wiring without factors: nodes of the given dimensions, and the node of each input and output+-- wire.+wiring+  :: forall {e} as bs+   . (KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => [Dim] -> [Node] -> [Node] -> TensorNetwork (TN as :: TNET e) (TN bs)+wiring dims is os = TensorNetwork (Net dims is os [])++-- | The wires going straight through, between two lists of the same dimensions.+straight+  :: forall {e} as bs. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => TensorNetwork (TN as :: TNET e) (TN bs)+straight = wiring (dimsOf @as) (wires @as) (wires @as)++-- | The arrow with the given entries, laid out as 'toVector' gives them. The length of the vector+-- must be the product of all the dimensions.+fromVector+  :: forall {e} as bs+   . (Scalar e, KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => SV.Vector e -> TensorNetwork (TN as :: TNET e) (TN bs)+fromVector vs+  | SV.length vs P./= P.product dims = P.error "fromVector: the length is not the product of the dimensions"+  | P.otherwise = TensorNetwork (Net dims is os [Factor (os P.++ is) vs])+  where+    dims = dimsOf @as P.++ dimsOf @bs+    is = wires @as+    os = [P.length is .. P.length dims - 1]++-- | The entries, row by row: a row for each index of the output wires and a column for each index+-- of the input wires, both with the last wire varying fastest. This relies on every node of the+-- network being on a wire, which composition keeps so.+toVector :: forall {e} a b. (Scalar e) => TensorNetwork (a :: TNET e) b -> SV.Vector e+toVector (TensorNetwork (Net dims is os fs))+  | distinct ws = values (product ws)+  | P.otherwise = SV.create do+      out <- MSV.replicate (extent dims ws) 0+      let vs = values (product order)+          go [] !src !dst = MSV.unsafeWrite out dst (vs `SV.unsafeIndex` src) P.>> P.pure (src + 1)+          go ((d, w) : rest) !src !dst = loop 0 src+            where+              loop !i !from+                | i == d = P.pure from+                | P.otherwise = go rest from (dst + i * w) P.>>= loop (i + 1)+      _ <- go [(dims P.!! n, P.sum [st | (x, st) <- P.zip ws wireStrides, x == n]) | n <- order] 0 0+      P.pure out+  where+    ws = os P.++ is+    -- the product of the factors, kept over the given nodes+    product keep = contract1 dims (case fs of [] -> unit; f : rest -> P.foldl times f rest) keep []+    times g h = contract dims g h (nubOrd (axes g P.++ axes h)) []+    -- with a node on several wires, each entry of the product over the nodes goes to the place+    -- that its wires give it, and the others are 0+    order = nubOrd ws+    wireStrides = P.drop 1 (P.scanr (*) 1 (P.fmap (dims P.!!) ws))++-- | The arrow with the given rows of entries, laid out as 'entries' gives them.+fromEntries+  :: forall {e} as bs+   . (Scalar e, KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => [[e]] -> TensorNetwork (TN as :: TNET e) (TN bs)+fromEntries rows = fromVector (SV.fromList (P.concat rows))++-- | The entries as rows, as 'toVector' lays them out.+entries :: forall {e} a b. (Scalar e) => TensorNetwork (a :: TNET e) b -> [[e]]+entries f@(TensorNetwork @as @bs _) = [SV.toList (SV.slice (r * ni) ni v) | r <- [0 .. size @bs - 1]]+  where+    v = toVector f+    ni = size @as++-- | The matrix of a function from the indices of the inputs to those of the outputs: each column+-- has a 1 in the row the function gives it.+reindex+  :: forall {e} as bs+   . (Scalar e, KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => (Index -> Index) -> TensorNetwork (TN as :: TNET e) (TN bs)+reindex f = fromVector (SV.generate (size @bs * ni) \k -> let (r, c) = k `P.quotRem` ni in if r == f c then 1 else 0)+  where+    ni = size @as++-- | The arrow with no entries, into or out of a wire of dimension 0.+zero+  :: forall {e} as bs+   . (Scalar e, KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => TensorNetwork (TN as :: TNET e) (TN bs)+zero = fromVector SV.empty++-- | The size of a list of dimensions: their product.+type Size :: [Nat] -> Nat+type family Size ns where+  Size '[] = 1+  Size (n ': ns) = n * Size ns++-- | The size of a list of dimensions, as a number.+size :: forall ns. (KnownListOf KnownNat ns) => Int+size = P.product (dimsOf @ns)++-- | The dimension of the direct sum of two lists of dimensions.+withSum+  :: forall as bs r. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => ((KnownNat (Size as + Size bs)) => r) -> r+withSum = withKnownNat n+  where+    n :: SNat (Size as + Size bs)+    n = withSomeSNat (P.fromIntegral (size @as + size @bs)) unsafeCoerce++-- | The product of two factors, with the given nodes kept, in that order, and the others summed.+contract :: forall e. (Scalar e) => [Dim] -> Factor e -> Factor e -> [Node] -> [Node] -> Factor e+contract dims f g keep summed+  | P.Just mm <- gemm, P.Just r <- viaGemm mm dims f g keep summed = r+  | P.otherwise =+      Factor+        keep+        ( kernel+            [(dims P.!! x, stride dims f x, stride dims g x) | x <- keep]+            (offsets f summed)+            (offsets g summed)+            (values f)+            (values g)+        )+  where+    -- the offset into a factor's entries of each index of the given nodes+    offsets h = P.foldl (\acc x -> step acc (dims P.!! x) (stride dims h x)) (UV.singleton 0)+    step acc d s = UV.generate (UV.length acc * d) \j -> let (q, r) = j `P.quotRem` d in acc `UV.unsafeIndex` q + r * s++-- | One factor with the given nodes kept, in that order, and the others summed: its product with the+-- unit. A factor with an axis twice gives its diagonal, and the entries are the same along a kept+-- node that it does not have.+contract1 :: (Scalar e) => [Dim] -> Factor e -> [Node] -> [Node] -> Factor e+contract1 dims f keep summed+  | P.null summed P.&& axes f == keep = f+  | P.otherwise = contract dims f unit keep summed++-- | The factor without axes whose entry is 1.+unit :: (P.Num e, Storable e) => Factor e+unit = Factor [] (SV.singleton 1)++-- | A contraction of two factors as a matrix product, when it is one: something is summed, every+-- summed node is on both factors, and the kept nodes of the first come before those of the second,+-- or after them, as the transposed product. A factor whose axes are in neither the order of its+-- matrix nor that of its transpose is rearranged first.+viaGemm :: (Scalar e) => Gemm e -> [Dim] -> Factor e -> Factor e -> [Node] -> [Node] -> P.Maybe (Factor e)+viaGemm mm dims f g keep summed+  | P.not (matrixProduct f g summed) P.|| rows * cols * inner P.< gemmWork = P.Nothing+  | keep == ms P.++ ns = P.Just (Factor keep (mm ta tb rows cols inner va vb))+  | keep == ns P.++ ms = P.Just (Factor keep (mm (P.not tb) (P.not ta) cols rows inner vb va))+  | P.otherwise = P.Nothing+  where+    ms = [x | x <- axes f, P.not (onFactor x g)]+    ns = [x | x <- axes g, P.not (onFactor x f)]+    ss = P.filter (`P.elem` summed) (axes f)+    rows = extent dims ms+    cols = extent dims ns+    inner = extent dims ss+    (ta, va) = matrix f ms ss+    (tb, vb) = matrix g ss ns+    -- a factor as a matrix with the first nodes as rows: transposed, or rearranged when it is not+    -- already in that order+    matrix h rs cs+      | axes h == cs P.++ rs = (P.True, values h)+      | P.otherwise = (P.False, values (contract1 dims h (rs P.++ cs) []))++-- | How far a step along a node moves in a factor's entries: the strides of its axes on that node,+-- 0 when it has none.+stride :: [Dim] -> Factor e -> Node -> Int+stride dims f node = P.sum [s | (a, s) <- P.zip (axes f) (P.drop 1 (P.scanr (*) 1 (P.fmap (dims P.!!) (axes f)))), a == node]++-- | Whether no element of the list is there twice.+distinct :: [Node] -> P.Bool+distinct = go IS.empty+  where+    go _ [] = P.True+    go seen (x : xs) = P.not (x `IS.member` seen) P.&& go (IS.insert x seen) xs++-- | Whether the node is on one of the factor's axes.+onFactor :: Node -> Factor e -> P.Bool+onFactor x f = x `P.elem` axes f++-- | Whether a product of two factors that sums the given nodes is a matrix product: something is+-- summed, and the nodes on both factors are the summed ones.+matrixProduct :: Factor e -> Factor e -> [Node] -> P.Bool+matrixProduct f g summed = P.not (P.null summed) P.&& Set.fromList [x | x <- axes f, onFactor x g] == Set.fromList summed++-- | The number of indices of the given nodes together.+extent :: [Dim] -> [Node] -> Int+extent dims = P.product P.. P.fmap (dims P.!!)++-- | The number of multiplications from which a matrix product goes to 'gemm'.+gemmWork :: Int+gemmWork = 4096++-- | The network with every factor's axes distinct, every node that is on no wire summed out, and+-- the nodes renumbered.+normalize :: (Scalar e) => Net e -> Net e+normalize (Net dims is os fs) =+  Net+    (P.fmap (dims P.!!) kept)+    (P.fmap renumber is)+    (P.fmap renumber os)+    (P.fmap relabel (scalars (loops P.++ sumOut reduced shared)))+  where+    summed = [n | n <- [0 .. P.length dims - 1], n `Set.notMember` keptSet]+    -- the number of factors on each node+    factorsOn n = IM.findWithDefault 0 n counts+    distinctAxes = [(f, nubOrd (axes f)) | f <- fs]+    counts = IM.fromListWith (+) [(m, 1 :: Int) | (_, as) <- distinctAxes, m <- as]+    -- each factor with its axes distinct, and the summed nodes that no other factor has summed out+    reduced =+      [ let own = [m | m <- as, m `Set.notMember` keptSet, factorsOn m == 1] in contract1 dims f (as List.\\ own) own+      | (f, as) <- distinctAxes+      ]+    -- the summed nodes on no factor, as of closed loops: a scalar of their dimensions+    loops = case [n | n <- summed, factorsOn n == 0] of+      [] -> []+      ns -> [Factor [] (SV.singleton (P.fromIntegral (extent dims ns)))]+    shared = [n | n <- summed, factorsOn n P.> 1]+    -- the factors on a shared node multiplied two at a time, first the pair whose result grows least+    -- (its size less those of the two factors, as the read-back chooses), each node summed out by+    -- the product that brings together the last two factors on it+    sumOut gs [] = gs+    sumOut gs ns@(n : _) =+      let (touching, others) = List.partition (onFactor n) gs+          numbered = P.zip [0 :: Int ..] touching+          pairs = [(f, g, [h | (k, h) <- numbered, k P./= i, k P./= j] P.++ others) | (i, f) <- numbered, (j, g) <- numbered, i P.< j]+          product (f, g, outside) =+            let ds = [m | m <- ns, onFactor m f P.|| onFactor m g, P.not (P.any (onFactor m) outside)]+                left = nubOrd (axes f P.++ axes g) List.\\ ds+                -- a product that is not a matrix product puts the nodes that a later product sums+                -- last, where a matrix product wants them+                keep = if matrixProduct f g ds then left else let (later, now) = List.partition (`P.elem` ns) left in now P.++ later+            in (extent dims keep - extent dims (axes f) - extent dims (axes g), (contract dims f g keep ds, outside, ds))+          (_, (fg, rest, done)) = List.minimumBy (comparing P.fst) (P.fmap product pairs)+      in sumOut (fg : rest) (ns List.\\ done)+    -- the factors without axes multiplied into one+    scalars gs = case List.partition (P.null P.. axes) gs of+      (c : d : more, rest) -> Factor [] (SV.singleton (P.product [SV.head (values x) | x <- c : d : more])) : rest+      _ -> gs+    kept = nubOrd (is P.++ os)+    keptSet = Set.fromList kept+    renumber = renumbering kept+    relabel (Factor as vs) = Factor (P.fmap renumber as) vs++-- | The new number of each of the given nodes: its place in the list.+renumbering :: [Node] -> Node -> Node+renumbering ns = (IM.fromList (P.zip ns [0 ..]) IM.!)++-- | Two networks side by side.+besideNet :: Net e -> Net e -> Net e+besideNet (Net d1 i1 o1 f1) (Net d2 i2 o2 f2) =+  Net (d1 P.++ d2) (i1 P.++ P.fmap (+ k) i2) (o1 P.++ P.fmap (+ k) o2) (f1 P.++ P.fmap shift f2)+  where+    k = P.length d1+    shift (Factor as vs) = Factor (P.fmap (+ k) as) vs++-- | The second network after the first: their wirings glued along the wires in between, and the+-- nodes that are then on no wire summed out.+composeNet :: (Scalar e) => Net e -> Net e -> Net e+composeNet f g+  | P.Just through <- permutation g = f{outs = P.fmap (outs f P.!!) through}+  | P.Just through <- permutation (transposeNet f) = g{ins = P.fmap (ins g P.!!) through}+  | P.otherwise =+      normalize+        ( Net+            [nodeDims both P.!! r | r <- live]+            (P.fmap node (ins f))+            (P.fmap (node P.. (+ k)) (outs g))+            [Factor (P.fmap node as) vs | Factor as vs <- factors both]+        )+  where+    both = besideNet f g+    k = P.length (nodeDims f)+    find = unionFind (P.zip (outs f) (P.fmap (+ k) (ins g)))+    -- the nodes that are left after gluing, numbered from 0+    live = nubOrd [find n | n <- [0 .. P.length (nodeDims both) - 1]]+    node = renumbering live P.. find++-- | For a wiring without factors whose every node has one input wire and at least one output wire,+-- such as a permutation or copying: the input wire that each output wire continues.+permutation :: Net e -> P.Maybe [Int]+permutation (Net _ is os fs)+  | P.not (P.null fs) P.|| P.not (distinct is) = P.Nothing+  | is == os = P.Just [0 .. P.length is - 1]+  | Set.fromList is == Set.fromList os = P.Just (P.fmap (renumbering is) os)+  | P.otherwise = P.Nothing++-- | The network the other way round.+transposeNet :: Net e -> Net e+transposeNet (Net d i o fs) = Net d o i fs++withAppend+  :: forall as bs r. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => ((KnownListOf KnownNat (as ++ bs)) => r) -> r+withAppend = withKnownListOf (appendListOf (listOf @KnownNat @as) (listOf @KnownNat @bs))++withAssoc+  :: forall as bs cs r+   . (KnownListOf KnownNat as, KnownListOf KnownNat bs, KnownListOf KnownNat cs)+  => ((KnownListOf KnownNat ((as ++ bs) ++ cs), KnownListOf KnownNat (as ++ (bs ++ cs))) => r) -> r+withAssoc r = withAppend @as @bs (withAppend @(as ++ bs) @cs (withAppend @bs @cs (withAppend @as @(bs ++ cs) r)))++-- | The arrow the other way round: its wiring with inputs and outputs swapped.+transpose :: TensorNetwork (a :: TNET e) b -> TensorNetwork b a+transpose (TensorNetwork n) = TensorNetwork (transposeNet n)++instance (Scalar e) => Profunctor (TensorNetwork :: CAT (TNET e)) where+  dimap = dimapDefault+  r \\ TensorNetwork{} = r++instance (Scalar e) => Promonad (TensorNetwork :: CAT (TNET e)) where+  id = straight+  TensorNetwork g . TensorNetwork f = TensorNetwork (composeNet f g)++-- | Tensor networks with entries @e@, between lists of dimensions.+instance (Scalar e) => CategoryOf (TNET e) where+  type (~>) = TensorNetwork+  type Ob a = (Is TN a, KnownListOf KnownNat (UN TN a))++-- | The conjugate transpose. 'dual' is the transpose without conjugating, since the compact-closed+-- structure is bilinear.+instance (Scalar e) => DaggerProfunctor (TensorNetwork :: CAT (TNET e)) where+  dagger (TensorNetwork n) = TensorNetwork (transposeNet n){factors = [Factor as (SV.map conj vs) | Factor as vs <- factors n]}++-- | A wire of dimension 0.+instance (Scalar e) => HasInitialObject (TNET e) where+  type InitialObject = TN '[0]+  initiate = zero++-- | A wire of dimension 0.+instance (Scalar e) => HasTerminalObject (TNET e) where+  type TerminalObject = TN '[0]+  terminate = zero++-- | The direct sum, as a single wire: the transpose of the product.+instance (Scalar e) => HasBinaryCoproducts (TNET e) where+  type a || b = TN '[Size (UN TN a) + Size (UN TN b)]+  withObCoprod @(TN as) @(TN bs) r = withSum @as @bs r+  lft @(TN as) @(TN bs) = withSum @as @bs (reindex P.id)+  rgt @(TN as) @(TN bs) = withSum @as @bs (reindex (size @as +))+  f ||| g = transpose (transpose f &&& transpose g)++-- | The direct sum, as a single wire: the entries of the first arrow above those of the second.+instance (Scalar e) => HasBinaryProducts (TNET e) where+  type a && b = TN '[Size (UN TN a) + Size (UN TN b)]+  withObProd @(TN as) @(TN bs) r = withSum @as @bs r+  fst @a @b = transpose (lft @_ @a @b)+  snd @a @b = transpose (rgt @_ @a @b)+  f@(TensorNetwork @_ @as _) &&& g@(TensorNetwork @_ @bs _) = withSum @as @bs (fromVector (toVector f SV.++ toVector g))++instance (Scalar e) => HasBiproducts (TNET e)++instance (Scalar e) => MonoidalProfunctor (TensorNetwork :: CAT (TNET e)) where+  one = id+  TensorNetwork @as @bs f ** TensorNetwork @cs @ds g = withAppend @as @cs (withAppend @bs @ds (TensorNetwork (besideNet f g)))++-- | The wires side by side as the tensor: on matrices, the Kronecker product.+instance (Scalar e) => Monoidal (TNET e) where+  type Unit = TN '[]+  type a ** b = TN (UN TN a ++ UN TN b)+  withOb2 @(TN as) @(TN bs) r = withAppend @as @bs r+  leftUnitor = id+  leftUnitorInv = id+  rightUnitor @(TN as) = withAppend @as @'[] straight+  rightUnitorInv @(TN as) = withAppend @as @'[] straight+  associator @(TN as) @(TN bs) @(TN cs) = withAssoc @as @bs @cs straight+  associatorInv @(TN as) @(TN bs) @(TN cs) = withAssoc @as @bs @cs straight++instance (Scalar e) => SymMonoidal (TNET e) where+  swap @(TN as) @(TN bs) =+    withAppend @as @bs $+      withAppend @bs @as $+        let na = P.length (dimsOf @as)+            nb = P.length (dimsOf @bs)+        in wiring (dimsOf @as P.++ dimsOf @bs) [0 .. na P.+ nb - 1] ([na .. na P.+ nb - 1] P.++ [0 .. na - 1])++-- | The distributors reorder the entries of the direct sums.+instance (Scalar e) => Distributive (TNET e) where+  distL @(TN as) @(TN bs) @(TN cs) =+    withSum @bs @cs $+      withAppend @as @'[Size bs + Size cs] $+        withAppend @as @bs $+          withAppend @as @cs $+            withSum @(as ++ bs) @(as ++ cs) $+              let (sa, sb, sc) = (size @as, size @bs, size @cs)+                  target c = let (i, k) = c `P.quotRem` (sb + sc) in if k P.< sb then i * sb + k else sa * sb + i * sc + k - sb+              in reindex target+  distR @(TN as) @(TN bs) @(TN cs) =+    withSum @as @bs $+      withAppend @as @cs $+        withAppend @bs @cs $+          withSum @(as ++ cs) @(bs ++ cs) $+            reindex P.id+  absorbL @(TN as) = withAppend @as @'[0] zero+  absorbR = zero++-- | Every object is self-dual, with the transpose as the dual of an arrow: its wiring the other way+-- round.+instance (Scalar e) => Dialogue (TNET e) where+  type Dual a = a+  withObDual r = r+  dual = transpose+  linDist @(TN as) @(TN bs) @(TN cs) (TensorNetwork (Net d i o f)) =+    withAppend @bs @cs $ let na = P.length (dimsOf @as) in TensorNetwork (Net d (P.take na i) (P.drop na i P.++ o) f)+  linDistInv @(TN as) @(TN bs) (TensorNetwork (Net d i o f)) =+    withAppend @as @bs $ let nb = P.length (dimsOf @bs) in TensorNetwork (Net d (i P.++ P.take nb o) (P.drop nb o) f)+  doubleNegInv = id++instance (Scalar e) => StarAutonomous (TNET e) where+  dualInv = transpose+  doubleNeg = id++instance (Scalar e) => Closed (TNET e) where+  type a ~~> b = ExpSA a b+  withObExp @(TN as) @(TN bs) r = withAppend @as @bs r+  curry @a @b = currySA @a @b+  apply @a @b = applySA @a @b+  (^^^) = expSA++instance (Scalar e) => IsoMix (TNET e) where+  dualUnit = id+  dualUnitInv = id+  dualityCounit @a = cap @a++instance (Scalar e) => CompactClosed (TNET e) where+  distribDual @(TN as) @(TN bs) = withAppend @as @bs id+  dualityUnit @a = cup @a++instance (Scalar e, MonoidalAction (t :: (TNET e, TNET e) +-> TNET e)) => Costrong t (TensorNetwork :: CAT (TNET e)) where+  coact @x = coactCC @t @x++-- | Merging each wire with its partner, and the unit.+instance (Scalar e, KnownListOf KnownNat ns) => Monoid (TN ns :: TNET e) where+  mempty = wiring (dimsOf @ns) [] (wires @ns)+  mappend = withAppend @ns @ns (wiring (dimsOf @ns) (wires @ns P.++ wires @ns) (wires @ns))++-- | Copying each wire, and discarding.+instance (Scalar e, KnownListOf KnownNat ns) => Comonoid (TN ns :: TNET e) where+  counit = wiring (dimsOf @ns) (wires @ns) []+  comult = withAppend @ns @ns (wiring (dimsOf @ns) (wires @ns) (wires @ns P.++ wires @ns))++-- | A node for each wire of a list.+wires :: forall ns. (KnownListOf KnownNat ns) => [Node]+wires = [0 .. P.length (dimsOf @ns) - 1]++instance (Scalar e, KnownListOf KnownNat ns) => CommutativeMonoid (TN ns :: TNET e)+instance (Scalar e, KnownListOf KnownNat ns) => CocommutativeComonoid (TN ns :: TNET e)+instance (Scalar e, KnownListOf KnownNat ns) => Frobenius (TN ns :: TNET e)+instance (Scalar e) => Hypergraph (TNET e)+instance (Scalar e) => CopyDiscard (TNET e)++-- | The size of an object is the product of its dimensions.+instance (Scalar e) => Sized (TNET e) where+  sizeOf @(TN ns) = size @ns++-- | Two objects are isomorphic when they have the same dimensions.+instance (Scalar e) => DecidableIso (TNET e) where+  isoOf @_ @(TN as) @(TN bs) =+    isoFromEquality+      ( P.fmap+          (\Refl -> Refl)+          (eqListOf @KnownNat (\ @x @y -> sameNat (Proxy @x) (Proxy @y)) (listOf @KnownNat @as) (listOf @KnownNat @bs))+      )
+ src/Proarrow/Category/Instance/TensorNetwork/Blas.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}++-- | Matrix products from the system's BLAS, for "Proarrow.Category.Instance.TensorNetwork". With+-- the package's @blas@ flag off they are all 'Nothing', and contractions use the generic loop.+module Proarrow.Category.Instance.TensorNetwork.Blas (Gemm, gemmDouble, gemmFloat, gemmComplexDouble) where++import Data.Complex (Complex (..))+import Data.Kind (Type)+import Data.Vector.Storable qualified as SV+import Prelude (Bool, Double, Float, Int, Maybe (..))++#ifdef BLAS+import Data.Vector.Storable.Mutable qualified as MSV+import Foreign.C.Types (CInt (..))+import Foreign.Marshal.Utils (with)+import Foreign.Ptr (Ptr)+import Foreign.Storable (Storable)+import System.IO.Unsafe (unsafeDupablePerformIO)+import Prelude (IO, fromIntegral, ($), (*))+#endif++-- | A matrix product: whether the first and second matrix are stored transposed, the numbers of+-- rows, columns and summed indices, and the two matrices, row by row; the result row by row.+type Gemm :: Type -> Type+type Gemm e = Bool -> Bool -> Int -> Int -> Int -> SV.Vector e -> SV.Vector e -> SV.Vector e++gemmDouble :: Maybe (Gemm Double)+gemmFloat :: Maybe (Gemm Float)+gemmComplexDouble :: Maybe (Gemm (Complex Double))++#ifdef BLAS+-- | A BLAS matrix product, with its scalars as the type @s@: the layout, whether each matrix is+-- transposed, the numbers of rows, columns and summed indices, then alpha, the first matrix and its+-- row length, the second and its row length, beta, and the result and its row length.+type CblasGemm :: Type -> Type -> Type+type CblasGemm e s =+  CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> s -> Ptr e -> CInt -> Ptr e -> CInt -> s -> Ptr e -> CInt -> IO ()++foreign import ccall safe "cblas_dgemm" cblas_dgemm :: CblasGemm Double Double+foreign import ccall safe "cblas_sgemm" cblas_sgemm :: CblasGemm Float Float+foreign import ccall safe "cblas_zgemm" cblas_zgemm :: CblasGemm (Complex Double) (Ptr (Complex Double))++-- | The product through a BLAS routine, given the scalars 1 and 0 as it takes them.+gemmWith :: (Storable e) => CblasGemm e s -> ((s -> s -> IO ()) -> IO ()) -> Gemm e+gemmWith routine scalars ta tb m n k a b = unsafeDupablePerformIO $ do+  -- beta is 0, so the result is not read before it is written+  c <- MSV.unsafeNew (m * n)+  scalars \one zero ->+    SV.unsafeWith a \pa -> SV.unsafeWith b \pb -> MSV.unsafeWith c \pc ->+      routine rowMajor (trans ta) (trans tb) (cint m) (cint n) (cint k) one pa (lead ta k m) pb (lead tb n k) zero pc (cint n)+  SV.unsafeFreeze c+  where+    rowMajor = 101+    trans t = if t then 112 else 111+    cint = fromIntegral+    -- the length of a stored row+    lead t notTransposed transposed = cint (if t then transposed else notTransposed)++gemmDouble = Just (gemmWith cblas_dgemm \k -> k 1 0)+gemmFloat = Just (gemmWith cblas_sgemm \k -> k 1 0)+gemmComplexDouble = Just (gemmWith cblas_zgemm \k -> with (1 :+ 0) \one -> with (0 :+ 0) \zero -> k one zero)+#else+gemmDouble = Nothing+gemmFloat = Nothing+gemmComplexDouble = Nothing+#endif
src/Proarrow/Category/Internal.hs view
@@ -34,7 +34,6 @@   , FmapWrap   , Index   , Indexed (..)-  , IndexedList (..)   , MapWrap   , Objects   , finite@@ -46,6 +45,7 @@ import Proarrow.Category.Instance.FinSet (FINSET (..), FinSet (..)) import Proarrow.Category.Instance.Ordinal (IsOrdinal, ORDINAL) import Proarrow.Core (CAT, CategoryOf (..), Hom, Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault, (\\))+import Proarrow.Object (lengthListOf) import Proarrow.Profunctor.Instance.Cone (Cone (..), Cosink (..))  -- | An internal category in a category @k@.@@ -103,11 +103,7 @@  -- | How many objects @k@ has, by walking its object list. obCount :: forall k. (Enumerable k) => Natural-obCount = go (finite @k)-  where-    go :: IndexedList (xs :: [k]) -> Natural-    go FNil = 0-    go (FCons xs) = 1 P.+ go xs+obCount = P.fromIntegral (lengthListOf (finite @k))  -- | Recover the object sitting at an index, together with the 'Ob' evidence that lets the -- 'Finitary' methods be called at it. The index must be below 'obCount'; every index the
src/Proarrow/Category/Monoidal/Applicative.hs view
@@ -2,8 +2,8 @@ {-# OPTIONS_GHC -Wno-orphans #-}  -- | Lax monoidal functors between monoidal categories: 'Applicative' generalizes the Prelude class--- with 'pure' and 'liftA2' stated via the tensor, and 'Alternative' adds coproduct structure over a--- 'Proarrow.Category.Monoidal.Distributive.Distributive' base.+-- with 'pure' and 'liftA2' stated via the tensor, and 'Alternative' is lax monoidal from the+-- coproduct of its source to the tensor of its target. module Proarrow.Category.Monoidal.Applicative where  import Control.Applicative qualified as P@@ -59,7 +59,7 @@ deriving via Prelude P.NonEmpty instance Applicative P.NonEmpty  type Alternative :: forall {j} {k}. (j -> k) -> Constraint-class (Distributive j, Functor f) => Alternative (f :: j -> k) where+class (HasBinaryCoproducts j, Monoidal k, Functor f) => Alternative (f :: j -> k) where   empty :: (Ob a) => Unit ~> f a   alt :: (Ob a, Ob b) => (a || b ~> c) -> f a ** f b ~> f c
src/Proarrow/Category/Monoidal/Distributive.hs view
@@ -15,8 +15,16 @@ import Proarrow.Category.Instance.Free (Elems, FREE, Free (..), HasStructure (..), Lower, withLowerOb) import Proarrow.Category.Instance.Product ((:**:) (..)) import Proarrow.Category.Instance.Unit qualified as U-import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), first, second, type (**!))-import Proarrow.Category.Monoidal.Action (CoprodAction)+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , MonoidalProfunctor (..)+  , SymMonoidal (..)+  , Tensor+  , first+  , second+  , type (**!)+  )+import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction) import Proarrow.Category.Monoidal.Closed (Closed (..), uncurry) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..)) import Proarrow.Category.Monoidal.Strength (MonStrong, Strong (..))@@ -38,7 +46,7 @@ import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Profunctor.Instance.Product ((:*:) (..))-import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..), repUniv)+import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..), repUniv) import Proarrow.Tools.Laws (Inverses (..), Labelled (..), Laws (..), inverses) import Prelude (($)) @@ -165,35 +173,69 @@         uncurry @c (curry @k @a @c (lft @k @(a ** c) @(b ** c)) ||| curry @k @b @c (rgt @k @(a ** c) @(b ** c)))  class-  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p) =>+  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p, Traversing p) =>   StrongDistributiveProfunctor (p :: k +-> k) instance-  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p)+  (DistributiveProfunctor (p :: k +-> k), MonStrong p, Strong CoprodAction p, Traversing p)   => StrongDistributiveProfunctor (p :: k +-> k) --- | The constant functor absorbs a coproduct action: the injected summand is discarded onto--- the monoid's unit, so this needs only copying\/discarding on the tensor side and coproducts.-instance (CopyDiscard k, HasCoproducts k, Monoid r) => Strong CoprodAction (Rep (Constant r) :: k +-> k) where-  act @(COPR a) (Rep @y p) = withObCoprod @k @a @y (Rep (mempty @r . discard @k @a ||| p))--type Traversable :: forall {k}. (k +-> k) -> Constraint-class (Profunctor t) => Traversable (t :: k +-> k) where-  traverse :: (StrongDistributiveProfunctor p) => t :.: p :~> p :.: t+-- | Distribution over a whole 'Traversable' witness, the @traverse'@ of the @profunctors@ library's+-- @Traversing@: a strong distributive profunctor built from 'one', '(**)', '(++)' and 'act' alone+-- only reaches finite shapes. The default runs the witness's own 'traverse', which for an unbounded+-- shape such as the list is a recursive value and needs a carrier whose values are functions, lazy+-- in 'dimap'. A carrier whose values are shapes, such as the generic optic carrier, absorbs the+-- witness instead. A 'Cotraversable' witness goes through @'CorepStar' t@ ('corepTraverse').+type Traversing :: forall {k}. (k +-> k) -> Constraint+class (Profunctor p) => Traversing (p :: k +-> k) where+  traverseP :: (Traversable t, Representable t) => t :.: p :~> p :.: t+  default traverseP :: (Traversable t, StrongDistributiveProfunctor p) => t :.: p :~> p :.: t+  traverseP = traverse  -- | With a representable traversable profunctor, you get a traversal a la one-liner. repTraverse   :: forall {k} (t :: k +-> k) p a b-   . (Traversable t, Representable t, StrongDistributiveProfunctor p)+   . (Traversable t, Representable t, Traversing p)   => p a b -> p (t % a) (t % b)-repTraverse p = p // case traverse (repUniv :.: p) of x :.: y -> rmap (index @t y) x+repTraverse p = p // case traverseP (repUniv :.: p) of x :.: y -> rmap (index @t y) x +-- | With a corepresentable cotraversable profunctor, you get a co-traversal a la one-liner: a+-- corepresentable @t@ is @'RepCostar' ('CorepStar' t)@, so this is 'repTraverse' at @'CorepStar' t@.+corepTraverse+  :: forall {k} (t :: k +-> k) p a b+   . (Cotraversable t, Corepresentable t, Traversing p)+  => p a b -> p (t %% a) (t %% b)+corepTraverse = repTraverse @(CorepStar t)+ -- | If both profunctors are representable, you get traversals as in base. baseTraverse   :: forall {k} (t :: k +-> k) f a b-   . (Traversable t, Representable t, Representable f, StrongDistributiveProfunctor f, Ob b)+   . (Traversable t, Representable t, Representable f, Traversing f, Ob b)   => a ~> f % b -> t % a ~> f % (t % b) baseTraverse = index . repTraverse @t @f @a @b . tabulate +instance (CopyDiscard k, HasCoproducts k, Monoid r) => Traversing (Rep (Constant r) :: k +-> k)+instance (SymMonoidal k, HasCoproducts k, Monoid m) => Traversing (Rep (ActionAt Tensor m) :: k +-> k)+instance (SymMonoidal k, HasCoproducts k) => Traversing (Id :: k +-> k)++-- | A composite carrier passes the witness through its halves in turn, so that each half can+-- absorb it.+instance (Traversing p, Traversing q) => Traversing (p :.: q) where+  traverseP (t :.: (p :.: q)) = case traverseP (t :.: p) of+    p' :.: t' -> case traverseP (t' :.: q) of+      q' :.: t'' -> (p' :.: q') :.: t''++-- | The constant functor absorbs a coproduct action: the injected summand is discarded onto+-- the monoid's unit, so this needs only copying\/discarding on the tensor side and coproducts.+instance (CopyDiscard k, HasCoproducts k, Monoid r) => Strong CoprodAction (Rep (Constant r) :: k +-> k) where+  act @(COPR a) (Rep @y p) = withObCoprod @k @a @y (Rep (mempty @r . discard @k @a ||| p))++-- | A witness that distributes any strong distributive profunctor through itself. For a+-- 'Representable' witness, callers go through 'traverseP' (or 'repTraverse'), which lets the carrier+-- absorb the witness instead of running 'traverse'.+type Traversable :: forall {k}. (k +-> k) -> Constraint+class (Profunctor t) => Traversable (t :: k +-> k) where+  traverse :: (StrongDistributiveProfunctor p) => t :.: p :~> p :.: t+ instance (CategoryOf k) => Traversable (Id :: k +-> k) where   traverse (Id f :.: p) = lmap f p :.: Id id \\ p @@ -209,17 +251,12 @@   traverse (InjL p :.: r) = case traverse (p :.: r) of r' :.: p' -> r' :.: InjL p'   traverse (InjR q :.: r) = case traverse (q :.: r) of r' :.: q' -> r' :.: InjR q' +-- | The dual of 'Traversable'. For a 'Corepresentable' witness, callers go through 'corepTraverse',+-- which is 'traverseP' at @'CorepStar' t@. type Cotraversable :: forall {k}. (k +-> k) -> Constraint class (Profunctor t) => Cotraversable (t :: k +-> k) where   cotraverse :: (StrongDistributiveProfunctor (p :: k +-> k)) => p :.: t :~> t :.: p --- | With a corepresentable cotraversable profunctor, you get a co-traversal a la one-liner.-corepTraverse-  :: forall {k} (t :: k +-> k) p a b-   . (Cotraversable t, Corepresentable t, StrongDistributiveProfunctor p)-  => p a b -> p (t %% a) (t %% b)-corepTraverse p = p // case cotraverse (p :.: corepUniv) of x :.: y -> lmap (coindex @t x) y- instance (CategoryOf k) => Cotraversable (Id :: k +-> k) where   cotraverse (p :.: Id f) = Id id :.: rmap f p \\ p @@ -239,9 +276,14 @@   cotraverse (r :.: InjL p) = case cotraverse (r :.: p) of p' :.: r' -> InjL p' :.: r'   cotraverse (r :.: InjR q) = case cotraverse (r :.: q) of q' :.: r' -> InjR q' :.: r' --- | This breaks for possibly infinite traversals like Star [].+-- | A corepresentable cotraversable witness, read as a traversable one.+instance (Cotraversable t, Corepresentable t) => Traversable (CorepStar t) where+  traverse (CorepStar l :.: p) =+    p // case cotraverse @t (p :.: corepUniv) of+      t' :.: p' -> lmap (coindex t' . l) p' :.: repUniv+ instance (Traversable t, Representable t) => Cotraversable (RepCostar t) where-  cotraverse (p :.: RepCostar t) = p // case traverse @t (repUniv :.: p) of p' :.: t' -> corepUniv :.: rmap (t . index t') p'+  cotraverse (p :.: RepCostar t) = p // case traverseP @_ @t (repUniv :.: p) of p' :.: t' -> corepUniv :.: rmap (t . index t') p'  -- | The tensor distributes over coproducts and is absorbed by the initial object: -- 'distL', 'distR', 'absorbL' and 'absorbR' are isomorphisms, with the inverses 'distLInv',
src/Proarrow/Category/Monoidal/Hypergraph.hs view
@@ -9,7 +9,7 @@  import Data.Kind (Constraint) import Data.Type.Nat (SNatI)-import Prelude (($))+import Prelude (Int, ($))  import Proarrow.Category.Instance.Free (FREE) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), NFold, NFoldS, SymMonoidal (..), (==))@@ -60,6 +60,14 @@ -- | A hypergraph category has a special frobenius algebra for every object, and the -- frobenius algebra of any tensor product X ⊗ Y is induced in the canonical way from those of X and Y. class (Supplies Frobenius k, CompactClosed k) => Hypergraph k++-- | How many values an object stands for, such as the dimension of a vector space or the number of+-- elements of a set: what 'Proarrow.Category.Instance.OpenHypergraph.readBack' weighs a wire by+-- when it chooses the order to contract boxes in. A category without a natural size can give every+-- object size 2, so that a bundle of wires costs more the more wires it has.+type Sized :: Kind -> Constraint+class (CategoryOf k) => Sized k where+  sizeOf :: forall (a :: k). (Ob a) => Int  -- | A hypergraph category is self-dual compact closed. dualHG :: forall {k} (a :: k) b. (Hypergraph k) => a ~> b -> b ~> a
src/Proarrow/Category/Monoidal/Strictified.hs view
@@ -5,8 +5,34 @@ -- list concatenation, and a morphism @as ~> bs@ is a @'Fold' as ~> 'Fold' bs@ in @k@ (the -- 'Strictified' arrow). Unitors and associators become identities, which makes composing long -- tensor expressions, string diagrams in particular, much more convenient.-module Proarrow.Category.Monoidal.Strictified where+module Proarrow.Category.Monoidal.Strictified+  ( -- * Lists of objects+    type (++)+  , IsList (..)+  , Obs+  , withObs+  , withIsListOf+  , Fold+  , fold+  , withObFold +    -- * The strictified category+  , Strictified (..)+  , (==)+  , singleton+  , obj1+  , concatMany+  , splitMany+  , swap2++    -- * Folding and splitting+  , concatFold+  , splitFold+  , foldAppendCase+  , splitThen+  , thenConcat+  ) where+ import Data.Kind (Constraint) import Prelude (($), type (~)) @@ -17,22 +43,14 @@   , SymMonoidal (..)   , associatorDefault   )-import Proarrow.Core (CAT, CategoryOf (..), Obj, Profunctor (..), Promonad (..), dimapDefault, obj)+import Proarrow.Core (CAT, CategoryOf (..), Ob', Obj, Profunctor (..), Promonad (..), dimapDefault, obj)+import Proarrow.Object (ListOf (..), type (++))  infixl 7 ==  (==) :: (CategoryOf k) => ((a :: k) ~> b) -> (b ~> c) -> a ~> c f == g = g . f -type family (as :: [k]) ++ (bs :: [k]) :: [k] where-  '[] ++ bs = bs-  (a ': as) ++ bs = a ': (as ++ bs)--data SList as where-  SNil :: SList '[]-  SSing :: (Ob a) => SList '[a]-  SCons :: (Ob a, Ob as, Ob bs, as ~ b ': bs) => SList (a ': as)- type IsList :: forall {k}. [k] -> Constraint class (CategoryOf k, Obs as, Strictly as) => IsList (as :: [k]) where   listCase@@ -40,28 +58,28 @@     -> (forall a. (Ob a, as ~ '[a]) => r)     -> (forall b bs c cs. (Ob b, Ob bs, Ob cs, as ~ (b ': bs), bs ~ (c ': cs)) => r)     -> r-  sList :: SList as+  sList :: ListOf Ob' as   withIsList2 :: (IsList bs) => ((IsList (as ++ bs)) => r) -> r   swap1 :: (Ob b, SymMonoidal k) => as ++ '[b] ~> b ': as   swap1Inv :: (Ob b, SymMonoidal k) => b ': as ~> as ++ '[b]   swap' :: (IsList (bs :: [k]), SymMonoidal k) => as ++ bs ~> bs ++ as instance (CategoryOf k) => IsList ('[] :: [k]) where   listCase n _ _ = n-  sList = SNil+  sList = Nil   withIsList2 r = r   swap1 = id   swap1Inv = id   swap' = id instance (Ob (a :: k), CategoryOf k) => IsList '[a] where   listCase _ s _ = s-  sList = SSing+  sList = Cons Nil   withIsList2 @bs r = listCase @bs r r r   swap1 @b = Str (swap @k @a @b)   swap1Inv @b = Str (swap @k @b @a)   swap' @bs = swap1Inv @bs @a instance (Ob (a1 :: k), IsList (a2 ': as), IsList as) => IsList (a1 ': a2 ': as) where   listCase _ _ c = c-  sList = SCons+  sList = Cons (sList @(a2 ': as))   withIsList2 @bs r = withIsList2 @(a2 ': as) @bs $ withIsList2 @as @bs r   swap1 @b = case swap1 @(a2 ': as) @b of f -> (Str @[a1, b] @[b, a1] (swap @_ @a1 @b) ** obj @(a2 ': as)) . (obj @'[a1] ** f)   swap1Inv @b = case swap1Inv @(a2 ': as) @b of f -> (obj @'[a1] ** f) . (Str @[b, a1] @[a1, b] (swap @_ @b @a1) ** obj @(a2 ': as))@@ -137,6 +155,13 @@    . (Ob as, Ob bs, Monoidal k)   => (x ~> Fold as ** Fold bs) -> x ~> Fold (as ++ bs) thenConcat h = foldAppendCase @as @bs h (concatFold @as @bs . h)++-- | The class from the list of its elements.+withIsListOf+  :: forall {k} (c :: k -> Constraint) (as :: [k]) r+   . (CategoryOf k, forall x. (c x) => Ob' x) => ListOf c as -> ((IsList as) => r) -> r+withIsListOf Nil r = r+withIsListOf (Cons @x @rest rest) r = withIsListOf rest (withIsList2 @'[x] @rest r)  type Strictified :: CAT [k] data Strictified as bs where
src/Proarrow/Colimit/Initial.hs view
@@ -58,6 +58,10 @@ instance (CategoryOf j, CategoryOf k) => HasInitialObject (j +-> k) where   type InitialObject = InitialProfunctor   initiate = Prof \case {}+  -- GHC 9.12 and later miscompile this when it is inlined: tag inference takes the thunk around the+  -- bottoming function for an evaluated 'Prof' in 'Sub''s strict field, which crashes the garbage+  -- collector (GHC MR !16719 fixes it)+  {-# NOINLINE initiate #-}  instance (HasInitialObject j, CategoryOf k) => Corepresentable (TerminalProfunctor :: j +-> k) where   type TerminalProfunctor %% x = InitialObject
src/Proarrow/Object.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ -- | Working with objects through their identity arrows: 'Obj' @a@ is @a '~>' a@ used as a witness that -- @a@ is an object, with 'obj', 'src' and 'tgt' to produce them and the 'Obj'\/'Objs' pattern synonyms -- to recover 'Ob' constraints from arrows and profunctor values.@@ -12,11 +14,31 @@   , VacuousOb   , objDicts   , ObjDict (..)++    -- * Lists of objects+  , type (++)+  , ListOf (..)+  , KnownListOf (..)+  , withKnownListOf+  , mapListOf+  , lengthListOf+  , appendListOf+  , eqListOf++    -- * One object of many+  , SomeOf (..)+  , someOfList+  , withListOf+  , someRepOf   ) where -import Data.Kind (Type)+import Data.Kind (Constraint, Type)+import Data.Type.Equality ((:~:) (..))+import Type.Reflection (SomeTypeRep (..), Typeable, typeRep)+import Prelude (Int, (+))+import Prelude qualified as P -import Proarrow.Core (CategoryOf (..), Ob', Obj, Profunctor, VacuousOb, obj, src, tgt, (\\))+import Proarrow.Core (CategoryOf (..), OB, Ob', Obj, Profunctor, VacuousOb, obj, src, tgt, (\\), type (:&&:))  type ObjDict :: forall {k}. k -> Type data ObjDict a where@@ -38,3 +60,83 @@ pattern Objs <- (objDicts -> (ObjDict, ObjDict))  {-# COMPLETE Objs #-}++-- | A type-level list with the evidence @c@ for each element, as a value.+type ListOf :: forall {k}. OB k -> [k] -> Type+data ListOf c xs where+  Nil :: ListOf c '[]+  Cons :: forall {k} {c :: OB k} (x :: k) xs. (c x) => ListOf c xs -> ListOf c (x ': xs)++-- | A type-level list whose elements have the evidence @c@, as its 'ListOf'.+type KnownListOf :: forall {k}. OB k -> [k] -> Constraint+class KnownListOf c xs where+  listOf :: ListOf c xs++instance KnownListOf c '[] where+  listOf = Nil+instance (c x, KnownListOf c xs) => KnownListOf c (x ': xs) where+  listOf = Cons @x listOf++-- | The class from the list.+withKnownListOf :: ListOf c xs -> ((KnownListOf c xs) => r) -> r+withKnownListOf Nil r = r+withKnownListOf (Cons rest) r = withKnownListOf rest r++-- | A value for each element, in order.+mapListOf :: forall {k} (c :: OB k) xs r. (forall (x :: k). (c x) => r) -> ListOf c xs -> [r]+mapListOf _ Nil = []+mapListOf f (Cons @x rest) = f @x : mapListOf @c (\ @y -> f @y) rest++-- | The number of elements.+lengthListOf :: ListOf c xs -> Int+lengthListOf Nil = 0+lengthListOf (Cons rest) = 1 + lengthListOf rest++-- | List concatenation.+type (++) :: [k] -> [k] -> [k]+type family as ++ bs where+  '[] ++ bs = bs+  (a ': as) ++ bs = a ': (as ++ bs)++-- | Whether two lists have the same elements, given how to decide that for one element.+eqListOf+  :: forall {k} (c :: OB k) as bs+   . (forall (x :: k) (y :: k). (c x, c y) => P.Maybe (x :~: y))+  -> ListOf c as+  -> ListOf c bs+  -> P.Maybe (as :~: bs)+eqListOf _ Nil Nil = P.Just Refl+eqListOf eq (Cons @x xs) (Cons @y ys) = case (eq @x @y, eqListOf @c eq xs ys) of+  (P.Just Refl, P.Just Refl) -> P.Just Refl+  _ -> P.Nothing+eqListOf _ _ _ = P.Nothing++-- | The elements of both lists.+appendListOf :: ListOf c as -> ListOf c bs -> ListOf c (as ++ bs)+appendListOf Nil ys = ys+appendListOf (Cons @x xs) ys = Cons @x (appendListOf xs ys)++-- | Some type with the evidence @c@, which one known only at runtime.+type SomeOf :: forall {k}. OB k -> Type+data SomeOf c where+  Some :: forall {k} {c :: OB k} (x :: k). (c x) => SomeOf c++-- | The elements of the list, each on its own.+someOfList :: forall {k} (c :: OB k) xs. ListOf c xs -> [SomeOf c]+someOfList = mapListOf (\ @x -> Some @x)++-- | A list of types known at runtime as a type-level list.+withListOf :: forall {k} (c :: OB k) r. [SomeOf c] -> (forall (xs :: [k]). ListOf c xs -> r) -> r+withListOf [] k = k Nil+withListOf (Some @x : rest) k = withListOf rest (\l -> k (Cons @x l))++-- | The type representation of the type, which is what 'SomeOf' values are compared and shown by.+someRepOf :: SomeOf (Typeable :&&: c) -> SomeTypeRep+someRepOf (Some @x) = SomeTypeRep (typeRep @x)++instance P.Eq (SomeOf (Typeable :&&: c)) where+  x == y = someRepOf x P.== someRepOf y+instance P.Ord (SomeOf (Typeable :&&: c)) where+  compare x y = P.compare (someRepOf x) (someRepOf y)+instance P.Show (SomeOf (Typeable :&&: c)) where+  show = P.show P.. someRepOf
src/Proarrow/Optic/Fold.hs view
@@ -9,9 +9,14 @@ module Proarrow.Optic.Fold where  import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..), UnOp)-import Proarrow.Category.Monoidal.Cartesian (Bicartesian) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))-import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..), corepTraverse, repTraverse)+import Proarrow.Category.Monoidal.Distributive+  ( Cotraversable (..)+  , Distributive+  , Traversable (..)+  , corepTraverse+  , repTraverse+  ) import Proarrow.Colimit.BinaryCoproduct (Coproduct, HasCoproducts, rgt, (|||)) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->)) import Proarrow.Limit.BinaryProduct (HasBinaryProducts, Product, snd)@@ -46,12 +51,12 @@   foldMapP (Id sa) am = am . sa instance (FoldFl f g, FoldFl f' g') => FoldFl (f :.: f') (g' :.: g) where   foldMapP (f :.: f') = foldMapP @f @g f . foldMapP @f' @g' f'-instance (Bicartesian k, Traversable t, Representable t) => FoldFl (t :: k +-> k) (RepCostar t) where+instance (Distributive k, CopyDiscard k, Traversable t, Representable t) => FoldFl (t :: k +-> k) (RepCostar t) where   foldMapP @m @_ @a l am = (case repTraverse @t @(Rep (Constant m)) (Rep @a am) of Rep sm -> sm . index l) \\ am  -- | The corepresentable-cotraversable witness folds by cotraversing at the fold profunctor -- @'Rep' ('Constant' m)@ and discarding the residual shape.-instance (Bicartesian k, Cotraversable t, Corepresentable t) => FoldFl (CorepStar t) (t :: k +-> k) where+instance (Distributive k, CopyDiscard k, Cotraversable t, Corepresentable t) => FoldFl (CorepStar t) (t :: k +-> k) where   foldMapP @m @_ @a (CorepStar l) am = (case corepTraverse @t @(Rep (Constant m)) (Rep @a am) of Rep sm -> sm . l) \\ am  instance (HasCoproducts k, Ob t) => FoldFl (Corep (Coproduct t) :: k +-> k) (Rep (Coproduct t)) where
src/Proarrow/Optic/Glass.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE LinearTypes #-}  -- | The __glass__ (Clarke et al., /Profunctor optics: a categorical update/): the optic for the -- combined action of the product and the exponential,
src/Proarrow/Optic/Grate.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE LinearTypes #-}  -- | The __grate__: the closed-category optic whose residual sits under an exponential, --@@ -19,7 +18,7 @@ import Proarrow.Category.Monoidal.Closed (Closed (..), Exp) import Proarrow.Colimit.BinaryCoproduct (HasCoproducts) import Proarrow.Core (CategoryOf (..), Promonad (..), obj, type (+->))-import Proarrow.Monoid (Comonoid)+import Proarrow.Monoid (CocommutativeComonoid) import Proarrow.Object (pattern Objs) import Proarrow.Optic   ( ExOptic@@ -57,7 +56,10 @@   => (x ~~> (m ~~> a)) ~> (m ~~> (x ~~> a)) flipExp = toSMC @(F x :-> F m :-> F a) @(F m :-> F x :-> F a) \f -> lam \m -> lam \x -> f ! x ! m -instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid m) => GrateFl (Rep (Exp m) :: k +-> k) (Corep (Exp m) :: k +-> k) where+instance+  (Closed k, SymMonoidal k, HasCoproducts k, CocommutativeComonoid m)+  => GrateFl (Rep (Exp m) :: k +-> k) (Corep (Exp m) :: k +-> k)+  where   zipWithP @_ @a (Rep sm) (Corep mbt) @x kk = mbt . (kk ^^^ obj @m) . flipExp @x @m @a . (sm ^^^ obj @x) instance (CategoryOf k) => GrateFl (Id :: k +-> k) (Id :: k +-> k) where   zipWithP (Id l) (Id r) @x kk = r . kk . (l ^^^ obj @x)@@ -81,7 +83,7 @@ -- 'Proarrow.Category.Monoidal.CopyDiscard.CopyDiscard' category every object is. grate   :: forall {k} (s :: k) (t :: k) a b-   . (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (s ~~> a), Ob s, Ob a, Ob b)+   . (Closed k, SymMonoidal k, HasCoproducts k, CocommutativeComonoid (s ~~> a), Ob s, Ob a, Ob b)   => (Mod s a b ~> t) -> Grate s t a b grate f@Objs =   withObExp @k @s @a $
src/Proarrow/Optic/Iso.hs view
@@ -10,8 +10,12 @@ -- express. 'fromPIso'\/'toPIso' mediate with the profunctor-class-flavored 'PIso'. module Proarrow.Optic.Iso where +import Data.Kind (Constraint)+import Data.Type.Equality ((:~:) (..)) import Proarrow.Category.Instance.Opposite (OPPOSITE (..))-import Proarrow.Core (CategoryOf (..), Promonad (..), type (+->))+import Prelude (Maybe, fmap)++import Proarrow.Core (CategoryOf (..), Kind, Promonad (..), type (+->)) import Proarrow.Optic   ( FLAVOR   , Flip@@ -60,6 +64,17 @@    . (CategoryOf k, (Ob a, Ob b) => c (Yo a (OP b)))   => Optic c s t a b -> ((s ~> a) -> (b ~> t) -> r) -> r withIso (Optic l) k = case l @(Yo a (OP b)) (Yo id id) of Yo sa bt -> k sa bt++-- | Categories where it can be decided whether two objects are isomorphic, with an isomorphism+-- when they are. The iso is an optic of any flavor @c@, so it can be used as a+-- 'Proarrow.Optic.PIso', an 'Iso' or anything those convert to, and taken apart with 'withIso'.+type DecidableIso :: Kind -> Constraint+class (CategoryOf k) => DecidableIso k where+  isoOf :: forall (c :: (k +-> k) -> Constraint) (a :: k) (b :: k). (Ob a, Ob b) => Maybe (Optic c a a b b)++-- | The identity iso when two objects are equal.+isoFromEquality :: forall {k} c (a :: k) b. (CategoryOf k, Ob a) => Maybe (a :~: b) -> Maybe (Optic c a a b b)+isoFromEquality = fmap (\Refl -> iso id id)  -- | The two iso encodings are equivalent: this direction instantiates the -- profunctor-class-flavored iso at the free 'IsoFl'-strong profunctor @ExOptic 'IsoFl' a b@,
src/Proarrow/Optic/Kaleidoscope.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -13,15 +12,15 @@ -- over @p@; the optics here take @p@ as the witness and quantify over @t@. -- -- * A 'Cotraversal' passes through every 'Cotraversable' carrier: the square for /arbitrary/ @p@.---   This holds for finite shapes ('Proarrow.Category.Monoidal.Distributive.Cotraversable'---   @('RepCostar' t)@ for a traversable representable @t@, 'Id', products, sums).+--   This holds for shapes with a list of contents ('Proarrow.Category.Monoidal.Distributive.Cotraversable'+--   @('RepCostar' t)@ for a traversable representable @t@, 'Id', products, sums, and in @Type@+--   @'Costar' ('Prelude' t)@ for a Prelude @Traversable t@, the @Aggregating@ module of the+--   literature). -- -- * A 'Kaleidoscope' passes through every 'Kaleidoscopic' carrier: the square for /representable/ --   @p@ only. This is the kaleidoscope of Clarke et al. (/Profunctor optics: a categorical update/),---   @∫^{F applicative} C(S, F A) × C(F B, T)@. In @Type@ it admits unbounded shapes such as---   @'Costar' t@ for a @Traversable t@ (the @Aggregating@ module of the literature). Those are not---   'Cotraversable': a generic structural recursion over a list diverges on strict witnesses such---   as 'Rep'.+--   @∫^{F applicative} C(S, F A) × C(F B, T)@. It admits every applicative, including ones with no+--   list of contents such as the reader @(->) r@, which are not 'Cotraversable'. -- -- Every 'Cotraversable' carrier is 'Kaleidoscopic' ('cotravAct'), so @'KaleidoFl' <: 'CotravFl'@: -- the kaleidoscope is the stronger flavor. Both sit below 'Proarrow.Optic.Setter.SetterFl' only,@@ -58,13 +57,18 @@ import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor) import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction) import Proarrow.Category.Monoidal.Closed (Closed (..), Exp)-import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), StrongDistributiveProfunctor, Traversable)+import Proarrow.Category.Monoidal.Distributive+  ( Cotraversable (..)+  , StrongDistributiveProfunctor+  , Traversable+  , Traversing+  ) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts) import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), obj, (//), (\\), type (+->)) import Proarrow.Functor (Prelude (..))-import Proarrow.Monoid (Comonoid (..), Monoid)+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..), Monoid) import Proarrow.Object (pattern Objs) import Proarrow.Optic (ExOptic, FLAVOR, Optic, Prostrong (..), legs2prof, withLegs) import Proarrow.Optic.Setter (SetterFl (..))@@ -73,7 +77,7 @@ import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..), repUniv)-import Proarrow.Tools.SMC (SYN (..), drop, dup, lam, lift, toSMC, (!))+import Proarrow.Tools.SMC (SYN (..), lam, lift, toSMC, (!)) import Proarrow.Tools.SMC qualified as SMC  -- * Carriers@@ -168,8 +172,8 @@ -- Rendered on @'Rep' ('Exp' m)@ (legs @a ~> (m ~~> b)@) this is a -- 'Proarrow.Category.Monoidal.Distributive.StrongDistributiveProfunctor', so a -- 'Proarrow.Optic.Grate.Grate' is a 'Proarrow.Optic.Kaleidoscope.Kaleidoscope'.-instance (Closed k, SymMonoidal k, Comonoid (m :: k)) => MonoidalProfunctor (Rep (Exp m) :: k +-> k) where-  one = Rep (toSMC @I @(F m :-> I) \u -> lam \i -> SMC.do () <- drop i; u)+instance (Closed k, SymMonoidal k, CocommutativeComonoid (m :: k)) => MonoidalProfunctor (Rep (Exp m) :: k +-> k) where+  one = Rep (toSMC @I @(F m :-> I) \u -> lam (P.const u))   Rep @x2 @_ @x1 l@Objs ** Rep @y2 @_ @y1 r@Objs =     withOb2 @k @x2 @y2 (Rep both)     where@@ -177,9 +181,7 @@         let l' = lift @(F x1) @(F m :-> F x2) l             r' = lift @(F y1) @(F m :-> F y2) r         (x, y) <- p-        lam \i -> SMC.do-          (i1, i2) <- dup i-          l' x ! i1 SMC.** r' y ! i2+        lam \i -> l' x ! i SMC.** r' y ! i  instance (Closed k, HasCoproducts k, Ob (m :: k)) => MonoidalProfunctor (Coprod (Rep (Exp m)) :: COPROD k +-> COPROD k) where   one = withObExp @k @m @InitialObject (Coprod (Rep initiate))@@ -205,9 +207,16 @@  -- | The exponential pair for a comonoid exponent: @m ~~> -@ is the reader applicative. So every -- 'Proarrow.Optic.Grate.Grate' is a kaleidoscope.-instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (m :: k)) => CotravFl (Rep (Exp m) :: k +-> k) (Corep (Exp m))+instance+  (Closed k, SymMonoidal k, HasCoproducts k, CocommutativeComonoid (m :: k))+  => CotravFl (Rep (Exp m) :: k +-> k) (Corep (Exp m)) -instance (Closed k, SymMonoidal k, HasCoproducts k, Comonoid (m :: k)) => KaleidoFl (Rep (Exp m) :: k +-> k) (Corep (Exp m)) where+instance (Closed k, SymMonoidal k, HasCoproducts k, CocommutativeComonoid (m :: k)) => Traversing (Rep (Exp m) :: k +-> k)++instance+  (Closed k, SymMonoidal k, HasCoproducts k, CocommutativeComonoid (m :: k))+  => KaleidoFl (Rep (Exp m) :: k +-> k) (Corep (Exp m))+  where   kaleidoP (Rep h) (Corep i) rab = dimap h i (kaleidoAct @_ @(Rep (Exp m)) rab)  instance (CategoryOf k) => CotravFl (Id :: k +-> k) (Id :: k +-> k) where
src/Proarrow/Optic/MonoidalTraversal.hs view
@@ -15,7 +15,12 @@ import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor) import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction, ProdAction) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..))-import Proarrow.Category.Monoidal.Distributive (Distributive, StrongDistributiveProfunctor)+import Proarrow.Category.Monoidal.Distributive+  ( Distributive+  , StrongDistributiveProfunctor+  , Traversable+  , Traversing (..)+  ) import Proarrow.Category.Monoidal.Strength (Strong (..), strongId) import Proarrow.Colimit.BinaryCoproduct   ( COPROD (..)@@ -54,7 +59,7 @@   ) import Proarrow.Profunctor.Corepresentable (Corep, Corepresentable (..)) import Proarrow.Profunctor.Instance.Composition ((:.:) (..))-import Proarrow.Profunctor.Representable (Rep, Representable (..))+import Proarrow.Profunctor.Representable (Rep, RepCostar, Representable (..)) import Prelude (Either (..), const, either, uncurry, ($))  type MonoidalTraversal (s :: k) (t :: k) a b = Optic (Prostrong MonTravFl) s t a b@@ -165,6 +170,14 @@       withObProd @k @(UN PR px) @z $         ExOptic @(Rep (Product (UN PR px)) :.: p) @(q :.: Corep (Product (UN PR px))) (repUniv :.: l) (r :.: corepUniv) +-- | The generic carrier absorbs a traversable witness by composing the pair @t@\/@'RepCostar' t@+-- onto its legs with 'proact', like any other witness pair.+instance+  (CategoryOf k, Flavor w, forall t. (Traversable t, Representable t) => w t (RepCostar t))+  => Traversing (ExOptic w a b :: k +-> k)+  where+  traverseP @t (tx :.: ex@(ExOptic _ Objs)) = proact @w (tx :.: ex :.: corepUniv @(RepCostar t)) :.: repUniv @t+ -- | The other half of the equivalence between the encodings: instantiate the profunctor-class -- traversal at @'ExOptic' 'MonTravFl' a b@, an SDP by the instances above. Its tensor strength -- comes from the tensor-action witness @'Rep' ('ActionAt' 'Tensor' _)@, so this needs only@@ -212,7 +225,7 @@ -- 'MonoidalTraversal'). Equivalent to 'Traversal' via 'toPTraversalFull' and 'traversal'. type PTraversalFull s t a b = Optic (StrongDistributiveProfunctor :&&: Strong ProdAction) s t a b --- | Build a 'Traversal' from its van-Laarhoven \/ profunctor-class form, by instantiating the+-- | Build a 'Traversal' from its profunctor-class form, by instantiating the -- rank-2 function at the generic carrier @'ExOptic' 'TravFl' a b@ (a 'StrongDistributiveProfunctor' -- /and/ @'Strong' 'ProdAction'@, unlike @'ExOptic' 'MonTravFl' a b@, since 'TravFl' contains the -- product-lens witness). The 'Traversal' analog of 'fromPTraversal'.
src/Proarrow/Optic/PowerGrate.hs view
@@ -41,7 +41,7 @@ import Proarrow.Category.Monoidal.Cartesian (Cartesian) import Proarrow.Category.Monoidal.Closed (Closed (..), mkExponential) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..), fst, snd, (&&&))-import Proarrow.Category.Monoidal.Distributive (Traversable (..))+import Proarrow.Category.Monoidal.Distributive (Traversable (..), Traversing) import Proarrow.Category.Monoidal.Strength (Strong (..)) import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts) import Proarrow.Colimit.Initial (HasInitialObject (..))@@ -213,6 +213,8 @@     withObCoprod @k @a @c (Coprod (Pow (powDist @n (lft @k @a @c) . f ||| powDist @n (rgt @k @a @c) . g))) instance (CopyDiscard k, SNatI n) => Strong M.Tensor (Pow n :: k +-> k) where   act @x (Pow @_ @_ @a f) = f // withOb2 @k @x @a (Pow (powZip @n @k @x @a . (fanOut @n @x ** f)))+instance (CopyDiscard k, HasCoproducts k, SNatI n) => Traversing (Pow n :: k +-> k)+ instance (CopyDiscard k, HasCoproducts k, SNatI n) => Strong CoprodAction (Pow n :: k +-> k) where   act @(COPR x) (Pow @_ @_ @a f) =     f // withObCoprod @k @x @a (Pow (powDist @n (lft @k @x @a) . fanOut @n @x ||| powDist @n (rgt @k @x @a) . f))
src/Proarrow/Optic/Traversal.hs view
@@ -8,15 +8,21 @@ -- the coproduct prism, 'Beside'\/'BesideSum' juxtaposition and the unit\/zero witnesses). The -- free-profunctor apparatus lives in "Proarrow.Optic.MonoidalTraversal". A traversal subtypes to -- 'Proarrow.Optic.Fold.Fold' and 'Proarrow.Optic.Setter.Setter'. Build with 'traversed' (from a--- 'Traversable') or 'Proarrow.Optic.MonoidalTraversal.traversal' (from the van-Laarhoven form),--- eliminate with 'traverseOf'.+-- 'Traversable'), 'fromTravVL' (from a Prelude traversal) or+-- 'Proarrow.Optic.MonoidalTraversal.traversal' (from the profunctor-class form), eliminate with+-- 'traverseOf'. module Proarrow.Optic.Traversal where +import Data.Functor.Compose (Compose (..))+import Data.Functor.Const (Const (..))+import Data.Functor.Identity (Identity (..))+import Data.Kind (Type)+import Prelude qualified as P+ import Proarrow.Adjunction (Proadjunction (..)) import Proarrow.Category.Instance.Product (Diag, (:**:) (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), MultRep, Tensor) import Proarrow.Category.Monoidal.Action (ActionAt, CoprodAction, ProdAction)-import Proarrow.Category.Monoidal.Cartesian (Bicartesian) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard (..)) import Proarrow.Category.Monoidal.Distributive   ( Cotraversable (..)@@ -38,6 +44,7 @@   ) import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (\\), type (+->))+import Proarrow.Functor (Prelude (..)) import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), PROD (..), Product) import Proarrow.Monoid (Comonoid, Monoid (..)) import Proarrow.Monoid qualified as Mon@@ -54,6 +61,7 @@ import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..), coindex) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, pattern Star) import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), RepCostar (..), Representable (..))  type TravFl :: forall {k}. FLAVOR k k@@ -72,8 +80,8 @@ class (TravFl p q) => MonTravFl (p :: k +-> k) (q :: k +-> k) where   monTravP :: (StrongDistributiveProfunctor r) => p s a -> q b t -> r a b -> r s t -instance (Bicartesian k, Traversable t, Representable t) => TravFl (t :: k +-> k) (RepCostar t)-instance (Bicartesian k, Traversable t, Representable t) => MonTravFl (t :: k +-> k) (RepCostar t) where+instance (Distributive k, CopyDiscard k, Traversable t, Representable t) => TravFl (t :: k +-> k) (RepCostar t)+instance (Distributive k, CopyDiscard k, Traversable t, Representable t) => MonTravFl (t :: k +-> k) (RepCostar t) where   monTravP l (RepCostar r) = dimap (index l) r . repTraverse @t  -- | A corepresentable 'Cotraversable' functor builds @s@ from a shape of @a@'s, and its 'travP'@@ -82,9 +90,9 @@ -- ("Proarrow.Optic.Kaleidoscope" does define a @Cotraversal@, over 'Cotraversable' witnesses that -- are not representable. In the lattice it is a sibling of 'Traversal', not a descendant: both are -- children of @Setter@, and @Cotraversal@\'s own child is @Kaleidoscope@.)-instance (Bicartesian k, Cotraversable t, Corepresentable t) => TravFl (CorepStar t) (t :: k +-> k)+instance (Distributive k, CopyDiscard k, Cotraversable t, Corepresentable t) => TravFl (CorepStar t) (t :: k +-> k) -instance (Bicartesian k, Cotraversable t, Corepresentable t) => MonTravFl (CorepStar t) (t :: k +-> k) where+instance (Distributive k, CopyDiscard k, Cotraversable t, Corepresentable t) => MonTravFl (CorepStar t) (t :: k +-> k) where   monTravP (CorepStar l) co = dimap l (coindex co) . corepTraverse @t  instance (HasBinaryProducts k, Ob (s :: k)) => TravFl (Rep (Product s)) (Corep (Product s)) where@@ -137,7 +145,7 @@ -- representable universal @'repUniv'@ and the identity 'RepCostar'. traversed   :: forall {k} (t :: k +-> k) a b-   . (Bicartesian k, Traversable t, Representable t, Ob a, Ob b) => Traversal (t % a) (t % b) a b+   . (Distributive k, CopyDiscard k, Traversable t, Representable t, Ob a, Ob b) => Traversal (t % a) (t % b) a b traversed = legs2prof @TravFl (repUniv @t) (corepUniv @(RepCostar t))  -- * The free traversal profunctor@@ -269,3 +277,43 @@ instance (HasInitialObject k) => Proadjunction (ZeroW :: k +-> k) CoZeroW where   unit = CoZeroW id :.: ZeroW id   counit (ZeroW h :.: CoZeroW i) = i . h++-- * Van Laarhoven traversals++-- | The van Laarhoven form of a traversal with target @t@ and new focus @b@, as a functor of the+-- old focus @a@: run with any applicative handling of the foci.+type Baz :: Type -> Type -> Type -> Type+newtype Baz t b a = Baz {runBaz :: forall f. (P.Applicative f) => (a -> f b) -> f t}++instance P.Functor (Baz t b) where+  fmap f (Baz m) = Baz (\k -> m (k P.. f))++instance P.Foldable (Baz t b) where+  foldMap f (Baz m) = getConst (m (Const P.. f))++-- | Handle the foci, keeping the rest of the traversal: run at @'Compose' f ('Bazaar' a' b)@.+instance P.Traversable (Baz t b) where+  traverse k (Baz m) = P.fmap (\(Bazaar m') -> Baz m') (getCompose (m (\a -> Compose (P.fmap (\a' -> Bazaar (\k' -> k' a')) (k a)))))++-- 'Baz' with its arguments in the order that makes it applicative in the result, for 'P.traverse'.+newtype Bazaar a b t = Bazaar (forall f. (P.Applicative f) => (a -> f b) -> f t)++instance P.Functor (Bazaar a b) where+  fmap f (Bazaar m) = Bazaar (\k -> P.fmap f (m k))++instance P.Applicative (Bazaar a b) where+  pure t = Bazaar (\_ -> P.pure t)+  Bazaar mf <*> Bazaar mx = Bazaar (\k -> mf k P.<*> mx k)++-- | Rebuild the target once every focus has its new type: run at 'Identity'.+sold :: Baz t b b -> t+sold (Baz m) = runIdentity (m Identity)++-- | Build a 'Traversal' from a Prelude traversal such as 'P.traverse'. Its witness is+-- @'Star' ('Prelude' ('Baz' t b))@ with the function as the left leg, so this does no work;+-- eliminating the result distributes the carrier through 'traverse' at the witness.+fromTravVL :: forall s t a b. (forall f. (P.Applicative f) => (a -> f b) -> s -> f t) -> Traversal s t a b+fromTravVL f =+  legs2prof @TravFl @(Star (Prelude (Baz t b))) @(RepCostar (Star (Prelude (Baz t b))))+    (Star (\s -> Prelude (Baz (`f` s))))+    (RepCostar (sold . unPrelude))
src/Proarrow/Profunctor/Free.hs view
@@ -16,15 +16,17 @@ import Proarrow.Category.Instance.Free (FREE (..), IsFreeOb (..), liftFree, retractFree) import Proarrow.Category.Instance.IntConstruction (INT (..), IntConstruction (..), toInt) import Proarrow.Category.Instance.Nat (Nat (..), first)+import Proarrow.Category.Instance.OpenHypergraph (SIMPLIFY, WireSorts, Wires, prim, simplifyWith) import Proarrow.Category.Instance.Prof (Prof (..)) import Proarrow.Category.Instance.Sub (Forget, On, SUBCAT (..), Sub (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), swap) import Proarrow.Category.Monoidal.Applicative (Applicative (..)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.Dialogue (Dual, dualObj)+import Proarrow.Category.Monoidal.Hypergraph (Hypergraph) import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.Strength (TracedMonoidal)-import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), (==))+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), singleton, (==)) import Proarrow.Core   ( CAT   , CategoryOf (..)@@ -246,3 +248,12 @@           Str @[ap, Dual am] @[Dual am, ap] (swap @_ @ap @(Dual am)) ** Str @'[] @[bm, Dual bm] (dualityUnit @_ @bm)             == obj @'[Dual am] ** Str @[ap, bm] @[am, bp] f ** obj @'[Dual bm]             == Str @[Dual am, am] @'[] (dualityCounit @_ @am) ** obj @'[bp] ** obj @'[Dual bm]++type instance FreeK CategoryOf Hypergraph k = SIMPLIFY k++type instance Lift CategoryOf Hypergraph (a :: k) = Wires '[a]+type instance Retract CategoryOf Hypergraph k ws = Fold (WireSorts ws) :: k++instance HasFreeK CategoryOf Hypergraph where+  liftK f = prim (singleton f) \\ f+  retractK f = unStr (simplifyWith (P.const 2) f)
src/Proarrow/Profunctor/Instance/Arrow.hs view
@@ -21,7 +21,7 @@  import Proarrow.Category.Monoidal (MonoidalProfunctor (..), Tensor) import Proarrow.Category.Monoidal.Action (CoprodAction)-import Proarrow.Category.Monoidal.Distributive (DistributiveProfunctor)+import Proarrow.Category.Monoidal.Distributive (DistributiveProfunctor, Traversing) import Proarrow.Category.Monoidal.Strength (Costrong (..), Strong (..)) import Proarrow.Colimit.BinaryCoproduct (Coprod (..), (++)) import Proarrow.Core (CAT, Profunctor (..), Promonad (..), rmap, type (+->))@@ -72,6 +72,8 @@  instance (Monad m) => Strong Tensor (Kleisli m) where   act = second++instance (MonadPlus m) => Traversing (Kleisli m)  instance (MonadPlus m) => Strong CoprodAction (Kleisli m) where   act (Kleisli a) = Kleisli ((return . Left) ||| (a >>> fmap Right))
src/Proarrow/Profunctor/Instance/Costar.hs view
@@ -15,7 +15,7 @@ import Proarrow.Category.Instance.Prof (Prof (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), withOb2) import Proarrow.Category.Monoidal.Cartesian (Cartesian)-import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable (..))+import Proarrow.Category.Monoidal.Distributive (Cotraversable (..), Traversable, Traversing (..)) import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), rmap, (//), (:~>), type (+->)) import Proarrow.Functor (Functor (..), Prelude (..), withObF) import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))@@ -68,7 +68,7 @@  instance (Functor t, Traversable (Star t)) => Cotraversable (Costar t) where   cotraverse @_ @a (p :.: Costar f) =-    p // withObF @t @a (Costar id :.: case traverse (Star id :.: p) of p' :.: Star g -> rmap (f . g) p')+    p // withObF @t @a (Costar id :.: case traverseP (Star id :.: p) of p' :.: Star g -> rmap (f . g) p')  instance (Functor f, Thin j) => ThinProfunctor (Costar f :: j +-> k) where   type HasArrow (Costar f :: j +-> k) a b = HasArrow (Hom j) (f a) b
src/Proarrow/Profunctor/Instance/Edges.hs view
@@ -29,6 +29,7 @@ import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Kind, Profunctor (..), obj, type (+->)) import Proarrow.Limit.BinaryProduct (type (&&))+import Proarrow.Object (KnownListOf (..), ListOf (..))  -- | A weighted graph on the bare set of points of an 'Indexed' kind, given as a list of edges with -- their weights in @v@: an enriched profunctor on the discrete category, since over a discrete base@@ -47,38 +48,61 @@   dimap Refl Refl e = e   r \\ Edge = r +-- | The source of an edge.+type EdgeSrc :: forall {k} {v}. (k, k, v) -> k+type family EdgeSrc e where+  EdgeSrc '(x, y, w) = x++-- | The target of an edge.+type EdgeTgt :: forall {k} {v}. (k, k, v) -> k+type family EdgeTgt e where+  EdgeTgt '(x, y, w) = y++-- | The weight of an edge.+type EdgeWeight :: forall {k} {v}. (k, k, v) -> v+type family EdgeWeight e where+  EdgeWeight '(x, y, w) = w++-- | An edge whose endpoints are known and whose weight is an object.+type KnownEdge :: forall {k} {v}. (k, k, v) -> Constraint+class+  (e ~ '(EdgeSrc e, EdgeTgt e, EdgeWeight e), KnownIndex (EdgeSrc e), KnownIndex (EdgeTgt e), Ob (EdgeWeight e)) =>+  KnownEdge e++instance+  (e ~ '(EdgeSrc e, EdgeTgt e, EdgeWeight e), KnownIndex (EdgeSrc e), KnownIndex (EdgeTgt e), Ob (EdgeWeight e))+  => KnownEdge e+ -- | The edge list, reflected to the value level.-type EdgeList :: forall {k} {v}. [(k, k, v)] -> Kind-data EdgeList es where-  ENil :: EdgeList '[]-  ECons :: forall x y w es. (KnownIndex x, KnownIndex y, Ob w) => EdgeList es -> EdgeList ('(x, y, w) ': es)+type EdgeList :: forall k v. [(k, k, v)] -> Kind+type EdgeList @k @v = ListOf (KnownEdge :: (k, k, v) -> Constraint)  type KnownEdges :: forall {k} {v}. [(k, k, v)] -> Constraint-class KnownEdges es where-  edges :: EdgeList es-instance KnownEdges '[] where-  edges = ENil-instance (KnownIndex x, KnownIndex y, Ob w, KnownEdges es) => KnownEdges ('(x, y, w) ': es) where-  edges = ECons edges+type KnownEdges es = KnownListOf KnownEdge es +-- | The weight of a pair, found by walking the edge list: the first continuation when the pair is+-- not listed, the second with the weight when it is.+lookupEdge+  :: forall {k} {v} (es :: [(k, k, v)]) a b r+   . (Indexed k, KnownIndex a, KnownIndex b)+  => EdgeList es+  -> ((WeightOf es a b ~ InitialObject) => r)+  -> (forall w. (WeightOf es a b ~ w, Ob w) => r)+  -> r+lookupEdge Nil none _ = none+lookupEdge (Cons @'(x, y, w) es) none found = case (decideEq @a @(D x), decideEq @b @(D y)) of+  (Yes Eq.Refl, Yes Eq.Refl) -> found @w+  (No, _) -> lookupEdge @_ @a @b es none found+  (Yes _, No) -> lookupEdge @_ @a @b es none found+ -- | A graph with 'BOOL' weights is a relation on the points: decided by walking the edge list. instance (Indexed k, KnownEdges es) => ThinProfunctor (Edges (es :: [(k, k, BOOL)]))  instance (Indexed k, KnownEdges es) => DecidableProfunctor (Edges (es :: [(k, k, BOOL)])) where   type Holds (Edges es) a b = WeightOf es a b-  decide @a @b = go (edges @es)-    where-      go-        :: forall (es' :: [(k, k, BOOL)])-         . (WeightOf es' a b ~ WeightOf es a b)-        => EdgeList es' -> Decision (Edges es) a b (WeightOf es' a b)-      go ENil = No-      go (ECons @x @y @w es') = case (decideEq @a @(D x), decideEq @b @(D y)) of-        (Yes Eq.Refl, Yes Eq.Refl) -> case obj @w of-          Tru -> Yes Edge-          Fls -> No-        (No, _) -> go es'-        (Yes _, No) -> go es'+  decide @a @b = lookupEdge @es @a @b listOf No \ @w -> case obj @w of+    Tru -> Yes Edge+    Fls -> No   toHolds Edge r = r  -- | The weight of a pair, reflected to the value level by walking the edge list.@@ -86,31 +110,14 @@   :: forall {k} {v} (es :: [(k, k, v)]) a b r    . (Quantale v, Indexed k, KnownEdges es, KnownIndex a, KnownIndex b)   => ((Ob (WeightOf es a b)) => r) -> r-withObWeight r = go (edges @es) r-  where-    go :: forall (es' :: [(k, k, v)]). EdgeList es' -> ((Ob (WeightOf es' a b)) => r) -> r-    go ENil r' = r'-    go (ECons @x @y es') r' = case (decideEq @a @(D x), decideEq @b @(D y)) of-      (Yes Eq.Refl, Yes Eq.Refl) -> r'-      (No, _) -> go es' r'-      (Yes _, No) -> go es' r'+withObWeight r = lookupEdge @es @a @b listOf r r  -- | A unit into a weight is an edge at the unit, since an object above the unit is the unit. enrichedEdge   :: forall {k} {v} (es :: [(k, k, v)]) a b    . (Quantale v, Indexed k, KnownEdges es, KnownIndex a, KnownIndex b)   => Unit ~> WeightOf es a b -> Edges es a b-enrichedEdge f = go (edges @es) f-  where-    go-      :: forall (es' :: [(k, k, v)])-       . (WeightOf es' a b ~ WeightOf es a b)-      => EdgeList es' -> Unit ~> WeightOf es' a b -> Edges es a b-    go ENil g = unitIsNotBottom @v g-    go (ECons @x @y @w es') g = case (decideEq @a @(D x), decideEq @b @(D y)) of-      (Yes Eq.Refl, Yes Eq.Refl) -> unitIsTop @v @w g Edge-      (No, _) -> go es' g-      (Yes _, No) -> go es' g+enrichedEdge f = lookupEdge @es @a @b listOf (unitIsNotBottom @v f) \ @w -> unitIsTop @v @w f Edge  -- | A graph with 'COST' weights: a weighted graph, whose closure is shortest paths. instance (Indexed k, KnownEdges es) => EnrichedProfunctor COST (Edges (es :: [(k, k, COST)])) where
src/Proarrow/Profunctor/Instance/List.hs view
@@ -46,10 +46,7 @@   type Ob as = (Is L as, Str.IsList (UN L as))  instance (Promonad p) => Promonad (List p) where-  id @(L bs) = case Str.sList @bs of-    Str.SNil -> Nil-    Str.SSing -> Cons id Nil-    Str.SCons -> Cons id id+  id @(L bs) = Str.listCase @bs Nil (Cons id Nil) (Cons id id)   Nil . Nil = Nil   Cons f fs . Cons g gs = Cons (f . g) (fs . gs) @@ -85,9 +82,11 @@   index Nil = Nil   index (Cons p Nil) = Cons (index @p p) Nil   index (Cons p ps@Cons{}) = mkCons (index @p p) (index @(List p) ps)-  tabulate @(L b) Nil = case Str.sList @b of Str.SNil -> Nil-  tabulate @(L b) (Cons f Nil) = case Str.sList @b of Str.SSing -> Cons (tabulate @p f) Nil-  tabulate @(L b) (Cons f fs@Cons{}) = case Str.sList @b of Str.SCons -> Cons (tabulate @p f) (tabulate @(List p) fs)+  tabulate @(L b) fs =+    Str.listCase @b+      (case fs of Nil -> Nil)+      (case fs of Cons f Nil -> Cons (tabulate @p f) Nil)+      (case fs of Cons f fs'@Cons{} -> Cons (tabulate @p f) (tabulate @(List p) fs'))   repMap Nil = Nil   repMap (Cons f Nil) = Cons (repMap @p f) Nil   repMap (Cons f fs@Cons{}) = mkCons (repMap @p f) (repMap @(List p) fs)
src/Proarrow/Profunctor/Instance/Star.hs view
@@ -6,8 +6,10 @@ module Proarrow.Profunctor.Instance.Star where  import Control.Monad qualified as P+import Data.Foldable qualified as P import Data.Functor.Compose (Compose (..)) import Data.Kind (Type)+import Data.Traversable qualified as P import Prelude qualified as P  import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision)@@ -16,8 +18,8 @@ import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Tensor) import Proarrow.Category.Monoidal.Action (CoprodAction, ProdAction, SubAction) import Proarrow.Category.Monoidal.Applicative (Alternative (..), Applicative (..))-import Proarrow.Category.Monoidal.Distributive (Distributive, Traversable (..), baseTraverse)-import Proarrow.Category.Monoidal.Strength (Strong (..))+import Proarrow.Category.Monoidal.Distributive (Distributive, Traversable (..), Traversing, baseTraverse, repTraverse)+import Proarrow.Category.Monoidal.Strength (MonStrong, Strong (..), strongId) import Proarrow.Colimit.BinaryCoproduct (COPROD (..), Coprod (..), HasBinaryCoproducts (..), HasCoproducts, (++)) import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Core (CategoryOf (..), Hom, Profunctor (..), Promonad (..), lmap, obj, (:~>), type (+->))@@ -83,15 +85,34 @@   one = Co (Star empty)   Co (Star @a f) ** Co (Star @b g) = let ab = obj @a +++ obj @b in Co (Star (alt @f @a @b ab . (f ** g))) \\ ab -instance (P.Functor f) => Strong ProdAction (Star (Prelude f)) where-  act (Star k) = Star (\(a, x) -> P.fmap (a,) (k x))+instance (Functor f) => Strong ProdAction (Star (f :: Type -> Type)) where+  act (Star k) = Star (\(a, x) -> map (a,) (k x))  instance (Functor f) => Strong Tensor (Star (f :: Type -> Type)) where   act (Star k) = Star (\(a, x) -> map (a,) (k x))-instance (Applicative f) => Strong CoprodAction (Star (f :: Type -> Type)) where-  act (Star k) = Star (f ||| map P.Right . k)++instance (Applicative f, MonStrong (Star f), HasCoproducts k) => Traversing (Star (f :: k -> k))++-- | A strong lax monoidal functor absorbs a coproduct action: the injected summand goes through+-- the natural unit @'unStar' 'strongId'@.+instance (Applicative f, MonStrong (Star f), HasCoproducts k) => Strong CoprodAction (Star (f :: k -> k)) where+  act @(COPR a) (Star @y k) =+    withObCoprod @k @a @y (Star (map (lft @k @a @y) . unStar (strongId @a) ||| map (rgt @k @a @y) . k))++-- | A Prelude traversable functor is a traversable witness: its contents are a list, traversed by+-- the list instance, and its shape is carried through as a residual that the new contents refill.+instance (P.Traversable g) => Traversable (Star (Prelude g)) where+  traverse (Star k :.: p) = lmap k (dimap split unsplit (act @Tensor (repTraverse @(Star []) p))) :.: Star id     where-      f a = pure (\() -> P.Left a) ()+      split (Prelude z) = (Shape (refill z), P.toList z)+      unsplit (Shape f, bs) = Prelude (f bs)+      refill z bs = P.snd (P.mapAccumL step bs z)+      step (b : bs) _ = (bs, b)+      step [] _ = P.error "Traversable (Star (Prelude g)): too few contents"++-- | The shape of a Prelude traversable functor, waiting for as many contents as it had.+type Shape :: (Type -> Type) -> Type+newtype Shape g = Shape (forall c. [c] -> g c)  instance (P.Applicative f) => Strong (SubAction P.Traversable ApplyAction) (Star (Prelude f)) where   act (Star f) = Star (P.traverse f)
src/Proarrow/Tools/Diagrams/Dot.hs view
@@ -8,10 +8,10 @@  import Data.Bifunctor (first) import Data.Char (digitToInt, isDigit)-import Data.Coerce (coerce) import Data.List qualified as List import Data.Proxy (Proxy (..))-import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)+import Data.Type.Equality ((:~:) (..))+import GHC.TypeLits (KnownSymbol, Symbol, sameSymbol, symbolVal) import Prelude hiding (Monoid (..), curry, id, (.))  import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Strictly (..), SymMonoidal (..), Tensor)@@ -23,6 +23,7 @@   ( ExpHG   , Frobenius   , Hypergraph+  , Sized (..)   , applyHG   , cap   , cup@@ -34,9 +35,11 @@ import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..)) import Proarrow.Category.Monoidal.Strength (Costrong (..))-import Proarrow.Category.Monoidal.Strictified (IsList (..), SList (..), type (++))+import Proarrow.Category.Monoidal.Strictified (IsList (..), type (++)) import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Object (eqListOf, lengthListOf, mapListOf)+import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality)  type Port = String -- Basically a shown int, but may contain an additional direction (:n, :e, :s, :w) @@ -56,16 +59,10 @@ split @as (Vec xs) = case splitAt (len @as) xs of (as, bs) -> (Vec as, Vec bs)  len :: (IsList as) => Int-len @as = case sList @as of-  SNil -> 0-  SSing -> 1-  SCons @_ @bs -> 1 + len @bs+len @as = lengthListOf (sList @as)  ixs :: (IsList as) => Vec as (Fin as)-ixs @as = case sList @as of-  SNil -> Vec []-  SSing -> Vec [0]-  SCons @_ @bs -> coerce (0 : fmap (+ 1) (unVec (ixs @bs)))+ixs @as = Vec (map Fin [0 .. len @as - 1])  ixed :: (IsList as) => Vec as x -> Vec as (Fin as, x) ixed (Vec []) = Vec []@@ -86,10 +83,7 @@   | otherwise = g (Fin (i - len @as))  names :: (IsList (as :: [Symbol])) => Vec as String-names @as = case sList @as of-  SNil -> Vec []-  SSing @s -> Vec [symbolVal (Proxy @s)]-  SCons @s @ss -> Vec (symbolVal (Proxy @s) : unVec (names @ss))+names @as = Vec (mapListOf (\ @s -> symbolVal (Proxy @s)) (sList @as))  type SymRefl :: CAT Symbol data SymRefl a b where@@ -256,6 +250,17 @@ -- be bent: each object is its own dual, with cups and caps drawn as a copy or merge point next to -- a unit or counit point. instance Hypergraph DOT++instance Sized DOT where+  sizeOf = 2++-- | Two objects are isomorphic when they have the same wires.+instance DecidableIso DOT where+  isoOf @_ @(D as) @(D bs) = isoFromEquality ((\Refl -> Refl) <$> eqListOf eqSymbol (sList @as) (sList @bs))++-- | Whether two symbols are the same.+eqSymbol :: forall x y. (KnownSymbol x, KnownSymbol y) => Maybe (x :~: y)+eqSymbol = sameSymbol (Proxy @x) (Proxy @y)  instance Closed DOT where   type a ~~> b = ExpHG a b
src/Proarrow/Tools/Diagrams/Svg.hs view
@@ -20,13 +20,15 @@ -- and the duals forgotten ('Erase'). module Proarrow.Tools.Diagrams.Svg where +import Control.Applicative ((<|>)) import Data.Functor.Identity (Identity (..))-import Data.Kind (Constraint)+import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) import Data.Proxy (Proxy (..))+import Data.Type.Equality ((:~:) (..)) import GHC.TypeLits (KnownSymbol, Symbol, symbolVal) import Numeric (showFFloat) import Prelude hiding (Monoid (..), curry, id, (**), (.))@@ -38,13 +40,12 @@ import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..)) import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard) import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))-import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cap, cup) import Proarrow.Category.Monoidal.IsoMix (IsoMix (..)) import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Category.Monoidal.Strictified   ( IsList (..)-  , SList (..)   , Strictified (..)   , obj1   , singleton@@ -53,6 +54,8 @@   ) import Proarrow.Core (CAT, CategoryOf (..), Is, Kind, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->)) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Object (eqListOf, mapListOf)+import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality) import Proarrow.Profunctor.Instance.Identity (Id (..)) import Proarrow.Tools.Diagrams.Dot (DOT, Dot) import Proarrow.Tools.Diagrams.Dot qualified as Dot@@ -101,9 +104,6 @@ -- 'withDualDual' and 'withEraseDual' prove them for lists by induction. type KnownWire :: W -> Constraint class KnownWire w where-  -- | The label of the wire as it is shown, and its kind.-  wireInfo :: (String, WireKind)-   withKnownDualW :: ((KnownWire (DualW w)) => r) -> r   withIsListEraseCons :: forall (ws :: [W]) r. (IsList (Erase ws)) => ((IsList (Erase (w ': ws))) => r) -> r   withEraseAppendCons@@ -115,8 +115,33 @@   withEraseDualCons     :: forall (ws :: [W]) r. (Erase (DualList ws) ~ Erase ws) => ((Erase (DualList (w ': ws)) ~ Erase (w ': ws)) => r) -> r +  -- | Which kind of wire it is, with its label.+  wireView :: WireView w++-- | A wire taken apart: its constructor, and the label as a known symbol.+type WireView :: W -> Type+data WireView w where+  WireV :: (KnownSymbol s) => WireView (Wire s)+  CoV :: (KnownSymbol s) => WireView (Co s)+  IV :: WireView I++-- | The label of the wire as it is shown, and its kind.+wireInfo :: forall w. (KnownWire w) => (String, WireKind)+wireInfo = case wireView @w of+  WireV @s -> (symbolVal (Proxy @s), Plain)+  CoV @s -> (symbolVal (Proxy @s) ++ "⁻¹", DualWire)+  IV -> ("𝐈", UnitWire)++-- | Whether two wires are the same.+eqWire :: forall a b. (KnownWire a, KnownWire b) => Maybe (a :~: b)+eqWire = case (wireView @a, wireView @b) of+  (WireV @s, WireV @t) -> (\Refl -> Refl) <$> Dot.eqSymbol @s @t+  (CoV @s, CoV @t) -> (\Refl -> Refl) <$> Dot.eqSymbol @s @t+  (IV, IV) -> Just Refl+  _ -> Nothing+ instance (KnownSymbol s) => KnownWire (Wire s) where-  wireInfo = (symbolVal (Proxy @s), Plain)+  wireView = WireV   withKnownDualW r = r   withIsListEraseCons @ws r = withIsList2 @'[s] @(Erase ws) r   withEraseAppendCons r = r@@ -124,7 +149,7 @@   withEraseDualCons r = r  instance (KnownSymbol s) => KnownWire (Co s) where-  wireInfo = (symbolVal (Proxy @s) ++ "⁻¹", DualWire)+  wireView = CoV   withKnownDualW r = r   withIsListEraseCons @ws r = withIsList2 @'[s] @(Erase ws) r   withEraseAppendCons r = r@@ -132,7 +157,7 @@   withEraseDualCons r = r  instance KnownWire I where-  wireInfo = ("𝐈", UnitWire)+  wireView = IV   withKnownDualW r = r   withIsListEraseCons r = r   withEraseAppendCons r = r@@ -202,10 +227,7 @@  -- | The labels of the wires of @ws@ as they are shown, and their kinds. wires :: forall (ws :: [W]). (IsList ws) => [(String, WireKind)]-wires = case sList @ws of-  SNil -> []-  SSing @w -> [wireInfo @w]-  SCons @w @ws' -> wireInfo @w : wires @ws'+wires = mapListOf (\ @w -> wireInfo @w) (sList @ws)  wireKinds :: forall (ws :: [W]). (IsList ws) => [WireKind] wireKinds = map snd (wires @ws)@@ -256,12 +278,26 @@   , fixedSpiders :: Bool   -- ^ keep the two legs of a copy or merge point in the order they are listed; otherwise they   -- may trade places to avoid a crossing, which the points being commutative allows+  , bendSpiders :: Bool+  -- ^ draw a merge point followed by a discard point as a cap, and a unit point followed by a copy+  -- point as a cup, which the points being a special commutative Frobenius algebra allows+  , slidePoints :: Bool+  -- ^ move each unit point down to just before what uses its wire, and each discard point up to+  -- just after what makes its wire, so that their wires are as short as possible   }   deriving (Show)  -- | Nothing drawn that the meaning does not need, legs in order. defaultOptions :: Options-defaultOptions = Options{explicitIdentities = False, explicitCoherence = False, explicitSwaps = False, fixedSpiders = True}+defaultOptions =+  Options+    { explicitIdentities = False+    , explicitCoherence = False+    , explicitSwaps = False+    , fixedSpiders = True+    , bendSpiders = False+    , slidePoints = False+    }  -- | The meaning of a diagram, forgetting how it is drawn. meaningOf :: Svg (S as) (S bs) -> Dot (Dot.D (Erase as)) (Dot.D (Erase bs))@@ -333,18 +369,24 @@  -- | The unit point takes the unit wire in, and the discard point gives it out. instance (Ob as) => Monoid (S as) where-  mempty = svg (mempty @(Dot.D (Erase as))) (Seq UnitEnd (Points UnitPoint (wireKinds @as)))+  mempty = svg (mempty @(Dot.D (Erase as))) (Seq UnitEnd (besides [Points UnitPoint [k] | k <- wireKinds @as]))   mappend = withIsList2 @as @as $ withEraseAppend @as @as $ svg (mappend @(Dot.D (Erase as))) (Points MergePoint (wireKinds @as))  instance (Ob as) => Comonoid (S as) where-  counit = svg (counit @(Dot.D (Erase as))) (Seq (Points DiscardPoint (wireKinds @as)) UnitStart)+  counit = svg (counit @(Dot.D (Erase as))) (Seq (besides [Points DiscardPoint [k] | k <- wireKinds @as]) UnitStart)   comult = withIsList2 @as @as $ withEraseAppend @as @as $ svg (comult @(Dot.D (Erase as))) (Points CopyPoint (wireKinds @as)) instance (Ob as) => CocommutativeComonoid (S as) instance (Ob as) => CommutativeMonoid (S as) instance (Ob as) => Frobenius (S as) instance CopyDiscard SVG instance Hypergraph SVG+instance Sized SVG where+  sizeOf = 2 +-- | Two objects are isomorphic when they have the same wires.+instance DecidableIso SVG where+  isoOf @_ @(S as) @(S bs) = isoFromEquality ((\Refl -> Refl) <$> eqListOf eqWire (sList @as) (sList @bs))+ -- | The exponential is the *-autonomous one, @'Dual' (a '**' 'Dual' b)@, so curried wires show as -- duals. instance Closed SVG where@@ -536,7 +578,7 @@  -- | The points a (co)monoid is drawn with. data PointKind = UnitPoint | DiscardPoint | CopyPoint | MergePoint-  deriving (Show)+  deriving (Eq, Show)  -- | Whether a bend opens downwards, a cup, or upwards, a cap. data BendKind = Cup | Cap@@ -555,14 +597,11 @@   deriving (Show)  -- | The diagram with its unit wires left out, and its unitors and associators turned into wires--- carrying straight on.+-- carrying straight on. What is left of a unit wire is an empty wiring, which is dropped. hideUnits :: Diagram -> Diagram hideUnits = \case   Ident ks -> Ident (noUnits ks)-  Permute c ks p ->-    let kept = [i | (i, k) <- zip [0 :: Int ..] ks, k /= UnitWire]-        renumber i = fromMaybe 0 (List.elemIndex i kept)-    in Permute c (map (ks !!) kept) [renumber i | i <- p, ks !! i /= UnitWire]+  Permute c ks p -> let (ks', p') = restrict (\i -> ks !! i /= UnitWire) ks p in Permute c ks' p'   Straight ks ls -> Straight (noUnits ks) (noUnits ls)   Node bk s ks os -> Node bk s (noUnits ks) [w | w@(_, k) <- os, k /= UnitWire]   Points pk ks -> Points pk (noUnits ks)@@ -571,8 +610,8 @@   Unitor _ _ ks -> straight (noUnits ks)   UnitEnd -> straight []   UnitStart -> straight []-  Seq a b -> Seq (hideUnits a) (hideUnits b)-  Beside a b -> Beside (hideUnits a) (hideUnits b)+  Seq a b -> rebuild [hideUnits a, hideUnits b]+  Beside a b -> besides [hideUnits a, hideUnits b]   Trace ks d -> Trace (noUnits ks) (hideUnits d)   where     straight ks = Straight ks ks@@ -580,9 +619,230 @@ noUnits :: [WireKind] -> [WireKind] noUnits = filter (/= UnitWire) +-- | Wires with a unit wire joining them on the given side.+withUnit :: Side -> [WireKind] -> [WireKind]+withUnit side ks = case side of+  OnLeft -> UnitWire : ks+  OnRight -> ks ++ [UnitWire]++-- | The kinds of the wires going into a diagram.+kindsIn :: Diagram -> [WireKind]+kindsIn = \case+  Ident ks -> ks+  Permute _ ks _ -> ks+  Straight ks _ -> ks+  Node _ _ ks _ -> ks+  Points pk ks -> case pk of+    UnitPoint -> []+    MergePoint -> ks ++ ks+    _ -> ks+  Bend b ka kd -> case b of+    Cup -> []+    Cap -> kd ++ ka+  Rebracket _ ka kb kc -> ka ++ kb ++ kc+  Unitor side d ks -> case d of+    Absorb -> withUnit side ks+    Create -> ks+  UnitEnd -> [UnitWire]+  UnitStart -> []+  Seq a _ -> kindsIn a+  Beside a b -> kindsIn a ++ kindsIn b+  Trace ks d -> drop (length ks) (kindsIn d)++-- | The kinds of the wires coming out of a diagram.+kindsOut :: Diagram -> [WireKind]+kindsOut = \case+  Ident ks -> ks+  Permute _ ks p -> map (ks !!) p+  Straight _ ls -> ls+  Node _ _ _ os -> map snd os+  Points pk ks -> case pk of+    DiscardPoint -> []+    CopyPoint -> ks ++ ks+    _ -> ks+  Bend b ka kd -> case b of+    Cup -> ka ++ kd+    Cap -> []+  Rebracket _ ka kb kc -> ka ++ kb ++ kc+  Unitor side d ks -> case d of+    Absorb -> ks+    Create -> withUnit side ks+  UnitEnd -> []+  UnitStart -> [UnitWire]+  Seq _ b -> kindsOut b+  Beside a b -> kindsOut a ++ kindsOut b+  Trace ks d -> drop (length ks) (kindsOut d)++-- | The steps of a stack, top to bottom.+steps :: Diagram -> [Diagram]+steps = \case+  Seq a b -> steps a ++ steps b+  d -> [d]++-- | A stack of the given steps, leaving out the empty wirings.+rebuild :: [Diagram] -> Diagram+rebuild = nonEmpty Seq++-- | The given diagrams side by side, leaving out the empty wirings.+besides :: [Diagram] -> Diagram+besides = nonEmpty Beside++nonEmpty :: (Diagram -> Diagram -> Diagram) -> [Diagram] -> Diagram+nonEmpty f ds = case filter (not . emptyWiring) ds of+  [] -> Ident []+  ds' -> foldr1 f ds'++-- | A wiring with no wires, which takes up no room.+emptyWiring :: Diagram -> Bool+emptyWiring = \case+  Ident [] -> True+  Straight [] [] -> True+  _ -> False++-- | Wires carrying straight on, as many as come in.+passThrough :: Diagram -> Bool+passThrough = \case+  Ident _ -> True+  Straight ks ls -> ks == ls+  _ -> False++-- | The wires of a permutation that @keep@ holds of, with the permutation among them.+restrict :: (Int -> Bool) -> [WireKind] -> [Int] -> ([WireKind], [Int])+restrict keep ks p =+  let kept = filter keep [0 .. length ks - 1]+      renumber i = fromMaybe 0 (List.elemIndex i kept)+  in (map (ks !!) kept, [renumber i | i <- p, keep i])++-- | The diagram with each unit point moved down to just before the first thing that uses its wire,+-- and each discard point moved up to just after the thing that makes its wire. A point moves past+-- wires carrying straight on and permutations, and into the stacks beside other wires, which the+-- interchange law allows; it stops at a box, a point, a bend or a trace, and stays where it is if+-- its wire leaves the stack.+slide :: Diagram -> Diagram+slide = along False . along True+  where+    -- when @down@ is false, discard points move up, and the steps are taken bottom to top+    along down d = fromSteps down (shorten down (toSteps down d))+    toSteps down = (if down then id else reverse) . steps+    fromSteps down = rebuild . (if down then id else reverse)+    parts = \case+      Beside a b -> parts a ++ parts b+      d -> [d]+    entering down = if down then kindsIn else kindsOut+    leaving down = if down then kindsOut else kindsIn+    origin down = \case+      Points UnitPoint [_] -> down+      Points DiscardPoint [_] -> not down+      _ -> False+    -- the parts of every step shortened first, then the points of each step moved along+    shorten down = go . map (besides . map (inner down) . parts)+      where+        go = \case+          [] -> []+          [s] -> [s]+          s : ss -> case break (origin down) (parts s) of+            (ls, _ : rs)+              | q <- length (concatMap (leaving down) ls)+              , not (usedNext down q ss)+              , (ss', Nothing) <- through down q ss ->+                  go (besides (ls ++ rs) : ss')+            _ -> s : go ss+    -- whether the next step uses the wire at position @q@ directly, so that the point is already+    -- next to it+    usedNext down q = \case+      s : _ | (_, p, _, _, _) <- partAt down q s -> not (passThrough p || isPermute p || isStack p)+      _ -> False+    isPermute = \case+      Permute{} -> True+      _ -> False+    isStack = \case+      Seq _ _ -> True+      _ -> False+    inner down = \case+      d@(Seq _ _) -> along down d+      Trace ks d -> Trace ks (along down d)+      d -> d+    -- the wire at position @q@ followed through the steps: @Nothing@ once the point is put just+    -- before what uses it, and the position it leaves at if it passes all of them+    through down q = \case+      [] -> ([], Just q)+      s : ss -> case step down q s of+        (s', Nothing) -> (s' : ss, Nothing)+        (s', Just q') -> let (ss', r) = through down q' ss in (s' : ss', r)+    -- the part of a step that the wire at position @q@ goes into: the parts before and after it,+    -- the wire's position in it, and where the wires leaving it start+    partAt down q s =+      let ps = parts s+          i = length (takeWhile (<= q) (scanl1 (+) (map (length . entering down) ps)))+          ls = take i ps+      in (ls, ps !! i, drop (i + 1) ps, q - length (concatMap (entering down) ls), length (concatMap (leaving down) ls))+    step down q s =+      let (ls, p, rs, o, b) = partAt down q s+          (p', r) = case p of+            Ident ks -> (Ident (without o ks), Just (b + o))+            Straight ks ls' -> (Straight (without o ks) (without o ls'), Just (b + o))+            Permute c ks perm ->+              -- the wire comes in at @i'@ and goes out at @j@+              let (i', j) = if down then (o, inverse perm !! o) else (perm !! o, o)+                  (ks', perm') = restrict (/= i') ks perm+              in (Permute c ks' perm', Just (b + if down then j else i'))+            Seq _ _ -> let (cs, r') = through down o (toSteps down p) in (fromSteps down cs, fmap (b +) r')+            _ -> (put down o p, Nothing)+      in (besides (ls ++ parts p' ++ rs), r)+    without o ks = take o ks ++ drop (o + 1) ks+    -- the point put just before @p@ on its wire at position @o@, or just after it when moving up+    put down o p =+      let ks = entering down p+          (l, k, r) = (take o ks, ks !! o, drop (o + 1) ks)+      in if down+           then Seq (besides [Ident l, Points UnitPoint [k], Ident r]) p+           else Seq p (besides [Ident l, Points DiscardPoint [k], Ident r])++-- | The diagram with each merge point followed by discard points on the same wires turned into a+-- cap, and unit points followed by a copy point on the same wires into a cup. Wires carrying straight on between+-- the two are skipped.+bends :: Diagram -> Diagram+bends = rebuild . fuse . concatMap inner . steps+  where+    inner = \case+      Beside a b -> [Beside (bends a) (bends b)]+      Trace ks d -> [Trace ks (bends d)]+      d -> [d]+    fuse = \case+      Points MergePoint ks : rest+        | (_, s : rest') <- span passThrough rest, pointsOn DiscardPoint s == Just ks -> Bend Cap ks ks : fuse rest'+      s : rest+        | Just ks <- pointsOn UnitPoint s+        , (_, Points CopyPoint ls : rest') <- span passThrough rest+        , ks == ls ->+            Bend Cup ks ks : fuse rest'+      -- two steps that split their wires at the same place, with wires carrying straight on on one+      -- side: by the interchange law the other sides form one stack, taken when its points fuse+      Beside a b : rest+        | (_, Beside c d : rest') <- span passThrough rest+        , Just f <- across a b c d Beside <|> across b a d c (flip Beside) ->+            fuse (f : rest')+      d : rest -> d : fuse rest+      [] -> []+    -- the wires of a step made only of points of the given kind, side by side+    pointsOn pk = \case+      Beside a b -> (++) <$> pointsOn pk a <*> pointsOn pk b+      Points pk' ks | pk' == pk -> Just ks+      _ -> Nothing+    across p x q y k = if passThrough p && passThrough q && kindsIn p == kindsIn q then k p <$> fused x y else Nothing+    -- the two sides, already bent, as one stack, when that fuses something+    fused x y =+      let ds = steps x ++ steps y+          fs = fuse ds+      in if length fs < length ds then Just (rebuild fs) else Nothing+ -- | The diagram laid out with the given options. layout :: Options -> Diagram -> Layout-layout o = go . if explicitCoherence o then id else hideUnits+layout o =+  go+    . (if bendSpiders o then bends else id)+    . (if slidePoints o then slide else id)+    . (if explicitCoherence o then id else hideUnits)   where     go = \case       Ident ks -> identity (explicitIdentities o) ks
+ src/Proarrow/Tools/Einsum.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Einstein summation with a numpy-style specification, as in @'einsum' \@"ij,jk->ik" a b@, in any+-- hypergraph category. A tensor is a state, @'Tensor' xs@, whose type lists the objects of its+-- indices. Each letter of the specification is an index; the letters of the inputs are matched with+-- the objects of the tensors given, so a letter used with two different objects does not compile,+-- and the result's objects are those of the output letters. Without @->@ the output is, as in+-- numpy, the letters used once, in alphabetical order. A letter may also occur more than once in the+-- output, which copies it.+--+-- The specification is an open hypergraph ("Proarrow.Category.Instance.OpenHypergraph"): a node for+-- each letter, the tensors as boxes, and the output letters as its boundary. It is already in normal+-- form, and the result is its 'Proarrow.Category.Instance.OpenHypergraph.simplify': the tensors+-- contracted in pairs, each letter summed out by a spider as soon as nothing still to come has it.+module Proarrow.Tools.Einsum+  ( Tensor+  , einsum+  , Einsum+  , EinsumType+  , Inputs+  , Output+  ) where++import Data.Containers.ListUtils (nubOrd)+import Data.Kind (Constraint, Type)+import Data.Map.Strict qualified as M+import Data.Proxy (Proxy (..))+import Data.Type.Bool (type (&&), type (||))+import Data.Type.Equality (type (==))+import GHC.TypeLits (CmpChar, ErrorMessage (..), KnownChar, Symbol, TypeError, UnconsSymbol, charVal)+import GHC.TypeNats (Nat, type (+))+import Prelude (Bool (..), Char, Maybe (..), Ordering (..), type (~))+import Prelude qualified as P++import Proarrow.Category.Instance.OpenHypergraph+  ( Box (..)+  , SIMPLIFY+  , SomeArrow (..)+  , SortList+  , Wires+  , simplify+  , someArrow+  , unsafeOpenHypergraph+  , unsafePrim+  )+import Proarrow.Category.Instance.Product (Fst, Snd)+import Proarrow.Category.Monoidal (State)+import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, Sized)+import Proarrow.Category.Monoidal.Strictified (Fold, type (++))+import Proarrow.Core (CategoryOf (..), Kind)+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Object (KnownListOf (..), mapListOf, someOfList)++-- | A tensor with indices of the given objects: a state of their tensor, as a morphism of+-- 'Proarrow.Category.Monoidal.Strictified.Strictified' from @'[]@.+type Tensor :: forall k. [k] -> Type+type Tensor xs = State xs++-- The specification++-- | A specification parsed into the letters of each input and of the output.+type Parse :: Symbol -> ([[Char]], [Char])+type Parse s = ParseInputs (UnconsSymbol s) '[] '[]++-- | The letters of each input.+type Inputs :: Symbol -> [[Char]]+type Inputs s = Fst @ Parse s++-- | The letters of the output.+type Output :: Symbol -> [Char]+type Output s = Snd @ Parse s++-- the letters of the current input, reversed, and the inputs before it, reversed+type ParseInputs :: Maybe (Char, Symbol) -> [Char] -> [[Char]] -> ([[Char]], [Char])+type family ParseInputs m cur acc where+  ParseInputs 'Nothing cur acc = Implicit (Finish cur acc)+  ParseInputs ('Just '( ',', s)) cur acc = ParseInputs (UnconsSymbol s) '[] (Reverse cur ': acc)+  ParseInputs ('Just '( ' ', s)) cur acc = ParseInputs (UnconsSymbol s) cur acc+  ParseInputs ('Just '( '-', s)) cur acc = ParseArrow (UnconsSymbol s) (Finish cur acc)+  ParseInputs ('Just '(c, s)) cur acc = ParseInputs (UnconsSymbol s) (c ': cur) acc++-- the inputs, with the letters of the last one+type Finish :: [Char] -> [[Char]] -> [[Char]]+type Finish cur acc = Reverse (Reverse cur ': acc)++type ParseArrow :: Maybe (Char, Symbol) -> [[Char]] -> ([[Char]], [Char])+type family ParseArrow m ins where+  ParseArrow ('Just '( '>', s)) ins = '(ins, ParseOutput (UnconsSymbol s) '[])+  ParseArrow _ _ = TypeError (Text "Proarrow.Tools.Einsum: expected > after - in the specification")++-- | The inputs with numpy's implicit output: the letters used once, in alphabetical order.+type Implicit :: [[Char]] -> ([[Char]], [Char])+type Implicit ins = '(ins, Sort (Once (Fold ins) (Fold ins)))++-- the letters of the first list that occur once in the second+type Once :: [Char] -> [Char] -> [Char]+type family Once cs all where+  Once '[] all = '[]+  Once (c ': cs) all = OnceIf (Count c all) c (Once cs all)++type OnceIf :: Nat -> Char -> [Char] -> [Char]+type family OnceIf n c cs where+  OnceIf 1 c cs = c ': cs+  OnceIf _ c cs = cs++type Count :: Char -> [Char] -> Nat+type family Count c cs where+  Count c '[] = 0+  Count c (c ': cs) = 1 + Count c cs+  Count c (d ': cs) = Count c cs++type Sort :: [Char] -> [Char]+type family Sort cs where+  Sort '[] = '[]+  Sort (c ': cs) = InsertSorted c (Sort cs)++type InsertSorted :: Char -> [Char] -> [Char]+type family InsertSorted c cs where+  InsertSorted c '[] = '[c]+  InsertSorted c (d ': ds) = InsertOrd (CmpChar c d) c d ds++type InsertOrd :: Ordering -> Char -> Char -> [Char] -> [Char]+type family InsertOrd o c d ds where+  InsertOrd 'GT c d ds = d ': InsertSorted c ds+  InsertOrd _ c d ds = c ': d ': ds++type ParseOutput :: Maybe (Char, Symbol) -> [Char] -> [Char]+type family ParseOutput m cur where+  ParseOutput 'Nothing cur = Reverse cur+  ParseOutput ('Just '( ' ', s)) cur = ParseOutput (UnconsSymbol s) cur+  ParseOutput ('Just '(c, s)) cur = ParseOutput (UnconsSymbol s) (c ': cur)++type Reverse :: [a] -> [a]+type Reverse xs = ReverseOnto xs '[]++type ReverseOnto :: [a] -> [a] -> [a]+type family ReverseOnto xs acc where+  ReverseOnto '[] acc = acc+  ReverseOnto (x ': xs) acc = ReverseOnto xs (x ': acc)++-- The indices++-- | The objects of the indices, by letter, in the order the letters first appear.+type Env :: Kind -> Kind+type Env k = [(Char, k)]++-- | The letters of the inputs matched with the objects of their tensors.+type BindAll :: forall k. [([Char], [k])] -> Env k -> Env k+type family BindAll ts env where+  BindAll '[] env = env+  BindAll ('(ls, xs) ': ts) env = BindAll ts (Bind ls xs env)++type Bind :: forall k. [Char] -> [k] -> Env k -> Env k+type family Bind ls xs env where+  Bind (c ': ls) (x ': xs) env = Bind ls xs (Insert c x env)+  Bind _ _ env = env++-- a letter already bound keeps its first object; 'Check' reports a second one+type Insert :: forall k. Char -> k -> Env k -> Env k+type family Insert c x env where+  Insert c x '[] = '[ '(c, x)]+  Insert c x ('(c, y) ': env) = '(c, y) ': env+  Insert c x (p ': env) = p ': Insert c x env++-- stuck at a letter no input has, which 'Check' reports+type Lookup :: forall k. Char -> Env k -> k+type family Lookup c env where+  Lookup c ('(c, x) ': env) = x+  Lookup c (p ': env) = Lookup c env++-- | The errors of a specification, reported once: a tensor with a different number of indices than+-- letters, a character that is not a letter, and, when there is neither, a letter used with two+-- objects and an output letter no input has. The other constraints of 'Einsum' get stuck instead+-- of repeating them.+type Check :: forall k. [([Char], [k])] -> [Char] -> Env k -> Constraint+type Check ts out env = Letters (LettersOf ts ++ out) (Arities ts (Agreements ts env, CheckOutput out env))++type LettersOf :: forall k. [([Char], [k])] -> [Char]+type family LettersOf ts where+  LettersOf '[] = '[]+  LettersOf ('(ls, xs) ': ts) = ls ++ LettersOf ts++-- the given constraint, when every index is a letter+type Letters :: [Char] -> Constraint -> Constraint+type family Letters ls c where+  Letters '[] c = c+  Letters (l ': ls) c = LetterIf (IsLetter l) l (Letters ls c)++type LetterIf :: Bool -> Char -> Constraint -> Constraint+type family LetterIf ok l c where+  LetterIf 'True l c = c+  LetterIf 'False l c =+    TypeError (Text "Proarrow.Tools.Einsum: " :<>: ShowType l :<>: Text " is not a letter, so it cannot be an index")++type IsLetter :: Char -> Bool+type IsLetter c = Within 'a' c 'z' || Within 'A' c 'Z'++-- whether the middle character is between the outer two+type Within :: Char -> Char -> Char -> Bool+type Within lo c hi = NotGT (CmpChar lo c) && NotGT (CmpChar c hi)++type NotGT :: Ordering -> Bool+type family NotGT o where+  NotGT 'GT = 'False+  NotGT _ = 'True++-- the given constraint, when every tensor has as many letters as indices+type Arities :: forall k. [([Char], [k])] -> Constraint -> Constraint+type family Arities ts c where+  Arities '[] c = c+  Arities ('(ls, xs) ': ts) c = ArityError (Len ls == Len xs) ls xs (Arities ts c)++type ArityError :: forall k. Bool -> [Char] -> [k] -> Constraint -> Constraint+type family ArityError ok ls xs c where+  ArityError 'True ls xs c = c+  ArityError 'False ls xs c =+    TypeError+      ( Text "Proarrow.Tools.Einsum: the tensor with indices "+          :<>: ShowType xs+          :<>: Text " has letters "+          :<>: ShowType ls+      )++type Agreements :: forall k. [([Char], [k])] -> Env k -> Constraint+type family Agreements ts env where+  Agreements '[] env = ()+  Agreements ('(c ': ls, x ': xs) ': ts) env = (Agrees c x env, Agreements ('(ls, xs) ': ts) env)+  Agreements ('(ls, xs) ': ts) env = Agreements ts env++type Agrees :: forall k. Char -> k -> Env k -> Constraint+type family Agrees c x env where+  Agrees c x ('(c, x) ': env) = ()+  Agrees c x ('(c, y) ': env) =+    TypeError+      ( Text "Proarrow.Tools.Einsum: the index "+          :<>: ShowType c+          :<>: Text " is used with both "+          :<>: ShowType y+          :<>: Text " and "+          :<>: ShowType x+      )+  Agrees c x (p ': env) = Agrees c x env++type CheckOutput :: forall k. [Char] -> Env k -> Constraint+type family CheckOutput out env where+  CheckOutput '[] env = ()+  CheckOutput (c ': out) env = (Bound c env, CheckOutput out env)++type Bound :: forall k. Char -> Env k -> Constraint+type family Bound c env where+  Bound c ('(c, x) ': env) = ()+  Bound c (p ': env) = Bound c env+  Bound c '[] =+    TypeError+      (Text "Proarrow.Tools.Einsum: the output letter " :<>: ShowType c :<>: Text " is not an index of any input")++-- | The objects of the given letters.+type Objs :: forall k. [Char] -> Env k -> [k]+type family Objs ls env where+  Objs '[] env = '[]+  Objs (c ': ls) env = Lookup c env ': Objs ls env++type Len :: [a] -> Nat+type family Len xs where+  Len '[] = 0+  Len (x ': xs) = 1 + Len xs++-- The network++-- | The letters as a value.+type KnownChars :: [Char] -> Constraint+type KnownChars ls = KnownListOf KnownChar ls++chars :: forall ls. (KnownChars ls) => [Char]+chars = mapListOf @KnownChar (\ @c -> charVal (Proxy @c)) (listOf @KnownChar @ls)++-- | The open hypergraph of a specification: a node for each letter, of the sort of its object, a box+-- for each tensor with an output for each of its letters, and the output letters as the boundary.+-- The type checker has matched the letters with the objects of the tensors and of the output, so+-- the hypergraph needs no checks.+network+  :: forall {k} (os :: [k])+   . (SortList os)+  => [([Char], SomeArrow k)]+  -> [Char]+  -> Wires '[] ~> (Wires os :: SIMPLIFY k)+network tensors out =+  unsafeOpenHypergraph+    (P.fmap (sortOfLetter M.!) letters)+    []+    (P.fmap (index M.!) out)+    [Box (unsafePrim t) [] (P.fmap (index M.!) ls) | (ls, t) <- tensors]+  where+    -- the letters in the order they first appear, with their sorts+    letters = nubOrd (P.concatMap P.fst tensors)+    sortOfLetter = M.fromList [(l, x) | (ls, SomeArrow _ ys _) <- tensors, (l, x) <- P.zip ls (someOfList ys)]+    index = M.fromList (P.zip letters [0 ..])++-- Einsum++-- | Collect the tensors of the inputs, then sum.+type Einsum :: forall {k}. [[Char]] -> [Char] -> [([Char], [k])] -> Type -> Constraint+class Einsum ins out (ts :: [([Char], [k])]) r where+  collect :: [([Char], SomeArrow k)] -> r++instance+  (r ~ (Tensor xs -> r'), KnownChars ls, SortList xs, Einsum ins out ('(ls, xs) ': ts) r')+  => Einsum (ls ': ins) out (ts :: [([Char], [k])]) r+  where+  collect acc t = collect @ins @out @('(ls, xs) ': ts) ((chars @ls, someArrow t) : acc)++-- The tensors are the boxes of an open hypergraph, which is read back with each box its tensor.+instance+  ( env ~ BindAll (Reverse ts) '[]+  , Check ts out env+  , Hypergraph k+  , Sized k+  , os ~ Objs out env+  , r ~ Tensor os+  , SortList os+  , KnownChars out+  )+  => Einsum '[] out (ts :: [([Char], [k])]) r+  where+  collect acc = simplify (network @os (P.reverse acc) (chars @out))++-- | Einstein summation: @einsum \@"ij,jk->ik" a b@ is the tensor with entries the sums over @j@ of+-- the products of the entries of @a@ and @b@. The tensors are given after the specification, one for+-- each input, and the result's type follows from theirs.+einsum :: forall {k} (s :: Symbol) r. (Einsum (Inputs s) (Output s) ('[] :: [([Char], [k])]) r) => r+einsum = collect @(Inputs s) @(Output s) @('[] :: [([Char], [k])]) []++-- | The type of @'einsum' \@s@ applied to tensors with indices of the given objects. Each letter+-- takes the object it is first given, so a letter given two objects is one type variable in every+-- input, as in+-- @'EinsumType' "ij,jk" '[ '[a, b], '[c, d]] = 'Tensor' '[a, b] -> 'Tensor' '[b, d] -> 'Tensor' '[a, d]@.+type EinsumType :: forall k. Symbol -> [[k]] -> Type+type EinsumType s xss = Arrows (Inputs s) (Output s) (BindAll (Zip (Inputs s) xss) '[])++type Zip :: [a] -> [b] -> [(a, b)]+type family Zip as bs where+  Zip (a ': as) (b ': bs) = '(a, b) ': Zip as bs+  Zip _ _ = '[]++type Arrows :: forall k. [[Char]] -> [Char] -> Env k -> Type+type family Arrows ins out env where+  Arrows '[] out env = Tensor (Objs out env)+  Arrows (ls ': ins) out env = Tensor (Objs ls env) -> Arrows ins out env
src/Proarrow/Tools/SMC.hs view
@@ -1,1429 +1,220 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE LinearTypes #-}-{-# LANGUAGE QualifiedDo #-}-{-# LANGUAGE RecursiveDo #-}---- | A HOAS front end for building morphisms in any symmetric monoidal category, the linear--- counterpart of "Proarrow.Tools.CCC", which grows with the structure of the target: traces,--- duals, additives, and the polarised System L reading of inputs and outputs in a dialogue--- category. Each variable is used exactly once: the functions on terms--- are linear, so GHC's linear types check that every variable is used once, and a 'Term' is--- indexed by its context, which is exactly the variables it uses. So a variable is the identity--- on its own type, and no copying or discarding is ever generated. Terms with disjoint contexts--- combine by merging the contexts, which only reorders wires. Functions on terms need--- @LinearTypes@ and linear arrows, e.g. @'Term' d g a %1 -> 'Term' d g b@.------ Types are 'SYN' expressions, interpreted in the target category by 'Interp'. Their tensor is a--- constructor, so a pattern can take a term's type apart, which the target's own @**@, a type--- family, would not allow.------ Every variable has an id, the number of binders around it, and a context lists its variables--- by descending id. Merging compares ids, so it only reduces where the depths are known, which is--- the case for terms built directly inside 'toSMC'. A reusable piece that binds variables of its--- own is compiled on its own: with 'closed' when it has no inputs, and used through 'call'--- otherwise.------ The module also provides @do@ notation, for use with @QualifiedDo@, and with @RecursiveDo@ a--- @rec@ block traces, which needs a traced monoidal category. Composition in the Int construction--- ("Proarrow.Category.Instance.IntConstruction") uses both: the two morphisms run side by side,--- and the wires each needs from the other are fed back.------ > import Proarrow.Tools.SMC (SYN (..), lift, toSMC, (**))--- > import Proarrow.Tools.SMC qualified as SMC--- >--- > Int @bp @bm @cp @cm f . Int @ap @am g =--- >   Int $ toSMC @(F ap :** F cm) \x -> SMC.do--- >     let g' = lift @(F ap :** F bm) @(F am :** F bp) g--- >         f' = lift @(F bp :** F cm) @(F bm :** F cp) f--- >     (ap, cm) <- x--- >     rec ((am, bp), (bm, cp)) <- g' (ap ** bm) ** f' (bp ** cm)--- >     am ** cp------ A bind takes its right hand side apart with a pattern, see /Patterns/ below. In a @rec@ block,--- the variables that are used before they are bound, @bm@ and @bp@ above, are fed back, and the others are passed on to the rest of--- the block. GHC's translation of @rec@ passes every variable of the block to its end again,--- including the ones a later statement of the block already used, so only such blocks work where--- no statement uses a variable bound by an earlier one. A block of a single statement always--- qualifies, and a nested pattern lets one statement bind everything, as above. 'loop' traces--- without GHC's translation, so it has neither restriction, but the type of the fed back variable--- has to be given.------ The module is inspired by Bernardy and Spiwack,--- [Evaluating Linear Functions to Symmetric Monoidal Categories](https://arxiv.org/abs/2103.06195), whose--- @P k r a@ ports correspond to 'Term', @encode@ to 'lift', @decode@ to 'toSMC', @(!:)@ to--- '(**)' and @split@ to 'split'. Unlike their implementation, it keeps the context thinned instead--- of computing in the cartesian structure and arguing afterwards that the result is monoidal.-module Proarrow.Tools.SMC-  ( -- * Types-    SYN (..)-  , Interp-  , KnownObj (..)-  , synOb--    -- * Patterns-    -- $patterns--    -- * Terms--    -- ** Symmetric monoidal categories-  , Term (..)-  , toSMC-  , lift-  , call-  , closed-  , unit-  , (**)-  , split-  , Tuple (..)-  , TupleCtx-  , TupleDepth-  , recast--    -- ** Closed categories-  , lam-  , (!)--    -- ** CopyDiscard / Comonoids-  , dup-  , drop--    -- ** Traced monoidal categories-  , loop--    -- * Inputs and outputs-    -- $inout--    -- ** Dialogue categories-  , Up-  , Consumer-  , Command-  , type (:##)-  , cont-  , cut-  , (|>)-  , ret-  , thunk-  , force--    -- ** Isomix categories-  , annihilate--    -- ** *-autonomous categories-  , classical--    -- ** Compact closed categories-  , produce--    -- * Additives-    -- $additives-  , with-  , exl-  , exr-  , absorb-  , inl-  , inr-  , caseOf-  , absurd--    -- * Contexts-  , Ctx-  , Mul-  , KnownCtx-  , ctxOb-  , withCtxOb-  , Union-  , Merge (..)-  , snoc-  , push2--    -- * Do notation-  , (>>=)-  , return-  , mfix-  , fail-  , Bind-  , BindPat-  , Binds-  , Pat-  , Ret-  , Rec-  , RecVars--    -- * Examples-  , swapT-  , rotT-  , applyT-  , curryT-  , traceT-  , loopT-  , loopCC-  , snakeT-  , snakeDualT-  , combineDualT-  , dniT-  , dneT-  , bindT-  , contraT-  , parSwapT-  , weakDistT-  , bothWaysT-  , distT-  , swapEitherT-  ) where--import Data.Kind (Constraint, Type)-import GHC.Exts (Multiplicity (..))-import GHC.TypeLits (ErrorMessage (..), TypeError)-import GHC.TypeNats (CmpNat, Nat, type (+))-import Prelude (Ordering (..), type (~))-import Prelude qualified as P--import Proarrow.Category.Monoidal-  ( Monoidal (..)-  , SymMonoidal (..)-  , Tensor-  , associator'-  , associatorInv'-  )-import Proarrow.Category.Monoidal qualified as M-import Proarrow.Category.Monoidal.Closed (Closed (..))-import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))-import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), Par, bindDual, dualityCounitSA)-import Proarrow.Category.Monoidal.Distributive (Distributive (..))-import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))-import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))-import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal, trace)-import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))-import Proarrow.Colimit.Initial (HasInitialObject (..))-import Proarrow.Core (CategoryOf (..), Promonad (..), obj)-import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))-import Proarrow.Limit.Terminal (HasTerminalObject (..))-import Proarrow.Monoid (Comonoid (..))-import Proarrow.Object (Obj)--infixl 7 **-infixl 1 |>-infixl 8 !-infixl 7 :**-infixl 7 :##-infixl 6 :&&-infixl 6 :||-infixr 5 :->---- | Type expressions over the objects of @k@: an object of @k@, the unit, the tensor, the--- internal hom and the negation, and the additives: the product and its unit 'Top', and the--- coproduct and its unit 'Zero'.------ The negation gives the types a polarity: a type is negative when it is a 'Not', and positive--- otherwise. A term of a positive type is a value, and a term of a negative type is a consumer--- of what it negates. 'Up' shifts a positive type to a negative one, and 'Dn' a negative type to--- a positive one, standing for the same object: a term of @'Dn' n@ is a stored term of @n@.-type data SYN k-  = F k-  | I-  | SYN k :** SYN k-  | SYN k :-> SYN k-  | Not (SYN k)-  | Dn (SYN k)-  | SYN k :&& SYN k-  | Top-  | SYN k :|| SYN k-  | Zero---- | The object of @k@ a type expression stands for.-type Interp :: forall {k}. SYN k -> k-type family Interp s where-  Interp (F a) = a-  Interp I = Unit-  Interp (a :** b) = Interp a ** Interp b-  Interp (a :-> b) = Interp a ~~> Interp b-  Interp (Not a) = Dual (Interp a)-  Interp (Dn a) = Interp a-  Interp (a :&& b) = Interp a && Interp b-  Interp Top = TerminalObject-  Interp (a :|| b) = Interp a || Interp b-  Interp Zero = InitialObject---- | Type expressions whose 'Interp' is an object, given that their leaves are.-type KnownObj :: forall {k}. SYN k -> Constraint-class (CategoryOf k) => KnownObj (s :: SYN k) where-  withSynOb :: ((Ob (Interp s)) => r) -> r--instance (CategoryOf k, Ob (a :: k)) => KnownObj (F a) where-  {-# INLINE withSynOb #-}-  withSynOb r = r--instance (Monoidal k) => KnownObj (I :: SYN k) where-  {-# INLINE withSynOb #-}-  withSynOb r = r--instance (Monoidal k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :** b) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a (withSynOb @b (withOb2 @k @(Interp a) @(Interp b) r))--instance (Closed k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :-> b) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a (withSynOb @b (withObExp @k @(Interp a) @(Interp b) r))--instance (KnownObj (a :: SYN k)) => KnownObj (Dn a) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a r--instance (Dialogue k, KnownObj (a :: SYN k)) => KnownObj (Not a) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a (withObDual @k @(Interp a) r)--instance (HasBinaryProducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :&& b) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a (withSynOb @b (withObProd @k @(Interp a) @(Interp b) r))--instance (HasTerminalObject k) => KnownObj (Top :: SYN k) where-  {-# INLINE withSynOb #-}-  withSynOb r = r--instance (HasBinaryCoproducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :|| b) where-  {-# INLINE withSynOb #-}-  withSynOb r = withSynOb @a (withSynOb @b (withObCoprod @k @(Interp a) @(Interp b) r))--instance (HasInitialObject k) => KnownObj (Zero :: SYN k) where-  {-# INLINE withSynOb #-}-  withSynOb r = r---- | The identity on the object a type expression stands for.-{-# INLINE synOb #-}-synOb :: forall {k} (s :: SYN k). (KnownObj s) => Obj (Interp s)-synOb = withSynOb @s (obj @(Interp s))---- | A context: the variables a term uses, each with its id and type, by descending id.-type Ctx :: Type -> Type-type Ctx k = [(Nat, SYN k)]---- | The type standing in for a context: the tensor of its variables' types, with the most--- recently bound variable on the right. A single variable is just its type, so a variable is the--- identity. The cost is that @Mul ('(n, a) ': g)@ only reduces once @g@ is known to be empty or--- not, which 'ctxCase' tells.-type Mul :: forall {k}. Ctx k -> SYN k-type family Mul g where-  Mul '[] = I-  Mul '[ '(n, a)] = a-  Mul ('(n, a) ': g) = Mul g :** a---- | A term at binding depth @d@ with context @g@ and type @a@: a morphism from the tensor of--- the context to @a@.-type Term :: forall {k}. Nat -> Ctx k -> SYN k -> Type-data Term d g a where-  MkTerm :: (Interp (Mul g) ~> Interp a) -> Term d g a---- | A context that is known to be empty or not, all the way down.-type KnownCtx :: forall {k}. Ctx k -> Constraint-class KnownCtx (g :: Ctx k) where-  -- | Case analysis on the context, which is what lets @'Mul' ('(n, a) ': g)@ reduce.-  ctxCase :: ((g ~ '[]) => r) -> (forall n a g'. (g ~ ('(n, a) ': g'), KnownObj a, KnownCtx g') => r) -> r--  -- | The tensor of a context is an object. A method rather than a function over 'ctxCase', so that-  -- at a known context it is not recursive and can be inlined.-  withCtxOb :: (Monoidal k) => ((Ob (Interp (Mul g))) => r) -> r--instance KnownCtx ('[] :: Ctx k) where-  {-# INLINE ctxCase #-}-  {-# INLINE withCtxOb #-}-  ctxCase e _ = e-  withCtxOb r = r--instance (KnownObj a, KnownCtx g) => KnownCtx ('(n, a) ': g) where-  {-# INLINE ctxCase #-}-  {-# INLINE withCtxOb #-}-  ctxCase _ c = c-  withCtxOb r = ctxCase @g (withSynOb @a r) (withCtxOb @g (withSynOb @a (withOb2 @_ @(Interp (Mul g)) @(Interp a) r)))---- | The identity on the tensor of a context.-{-# INLINE ctxOb #-}-ctxOb :: forall {k} (g :: Ctx k). (Monoidal k, KnownCtx g) => Obj (Interp (Mul g))-ctxOb = withCtxOb @g (obj @(Interp (Mul g)))---- | A new variable on the right of a context: a unitor if the context was empty, and nothing--- otherwise.-{-# INLINE snoc #-}-snoc-  :: forall {k} n (a :: SYN k) g-   . (Monoidal k, KnownObj a, KnownCtx g) => Interp (Mul g) ** Interp a ~> Interp (Mul ('(n, a) ': g))-snoc = ctxCase @g (withSynOb @a leftUnitor) (ctxOb @('(n, a) ': g))---- | The context of two terms used side by side.-type Union :: forall {k}. Ctx k -> Ctx k -> Ctx k-type family Union g1 g2 where-  Union '[] g2 = g2-  Union g1 '[] = g1-  Union ('(n, a) ': g1) ('(m, b) ': g2) = UnionBy (CmpNat n m) ('(n, a) ': g1) ('(m, b) ': g2)--type UnionBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k-type family UnionBy o g1 g2 where-  UnionBy GT (x ': g1) g2 = x ': Union g1 g2-  UnionBy LT g1 (y ': g2) = y ': Union g1 g2-  UnionBy EQ _ _ = TypeError (Text "Proarrow.Tools.SMC: a variable is used more than once")---- | Split the tensor of a merged context into the tensors of the two contexts it came from, and--- back. This is where the wires are reordered, and the only place 'swap' is used.-type Merge :: forall {k}. Ctx k -> Ctx k -> Constraint-class (KnownCtx g1, KnownCtx g2) => Merge (g1 :: Ctx k) g2 where-  merge :: Interp (Mul (Union g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)-  unmerge :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (Union g1 g2))--instance (Monoidal k, KnownCtx g2) => Merge ('[] :: Ctx k) g2 where-  {-# INLINE merge #-}-  {-# INLINE unmerge #-}-  merge = withCtxOb @g2 leftUnitorInv-  unmerge = withCtxOb @g2 leftUnitor--instance (Monoidal k, KnownCtx ('(n, a) ': g1)) => Merge ('(n, a) ': g1 :: Ctx k) '[] where-  {-# INLINE merge #-}-  {-# INLINE unmerge #-}-  merge = withCtxOb @('(n, a) ': g1) rightUnitorInv-  unmerge = withCtxOb @('(n, a) ': g1) rightUnitor--instance-  ( Monoidal k-  , KnownObj a-  , KnownObj b-  , KnownCtx g1-  , KnownCtx g2-  , MergeBy (CmpNat n m) ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)-  )-  => Merge ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)-  where-  {-# INLINE merge #-}-  {-# INLINE unmerge #-}-  merge = mergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)-  unmerge = unmergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)---- | 'merge' and 'unmerge' for two non-empty contexts, by which of the two has the larger head id.-type MergeBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Constraint-class (KnownCtx g1, KnownCtx g2) => MergeBy o (g1 :: Ctx k) g2 where-  mergeBy :: Interp (Mul (UnionBy o g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)-  unmergeBy :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (UnionBy o g1 g2))---- The union of two non-empty contexts is not empty, so its tensor splits off the newest variable--- as is, which the equality says for GHC. If the newest variable is alone on its side, merging is--- one swap or nothing.-instance-  ( SymMonoidal k-  , Merge g1 ('(m, b) ': g2)-  , KnownObj (a :: SYN k)-  , KnownObj b-  , Mul ('(n, a) ': Union g1 ('(m, b) ': g2)) ~ (Mul (Union g1 ('(m, b) ': g2)) :** a)-  )-  => MergeBy GT ('(n, a) ': g1) ('(m, b) ': g2)-  where-  {-# INLINE mergeBy #-}-  {-# INLINE unmergeBy #-}-  mergeBy =-    withCtxOb @('(m, b) ': g2)-      ( withSynOb @a-          ( ctxCase @g1-              (swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))-              ( associatorInv' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))-                  . (ctxOb @g1 M.** swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))-                  . associator' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)-                  . (merge @g1 @('(m, b) ': g2) M.** synOb @a)-              )-          )-      )-  unmergeBy =-    withCtxOb @('(m, b) ': g2)-      ( withSynOb @a-          ( ctxCase @g1-              (swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))-              ( (unmerge @g1 @('(m, b) ': g2) M.** synOb @a)-                  . associatorInv' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)-                  . (ctxOb @g1 M.** swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))-                  . associator' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))-              )-          )-      )--instance-  ( Monoidal k-  , Merge ('(n, a) ': g1) g2-  , KnownObj a-  , KnownObj (b :: SYN k)-  , Mul ('(m, b) ': Union ('(n, a) ': g1) g2) ~ (Mul (Union ('(n, a) ': g1) g2) :** b)-  )-  => MergeBy LT ('(n, a) ': g1) ('(m, b) ': g2)-  where-  {-# INLINE mergeBy #-}-  {-# INLINE unmergeBy #-}-  mergeBy =-    ctxCase @g2-      (ctxOb @('(m, b) ': '(n, a) ': g1))-      ( associator' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)-          . (merge @('(n, a) ': g1) @g2 M.** synOb @b)-      )-  unmergeBy =-    ctxCase @g2-      (ctxOb @('(m, b) ': '(n, a) ': g1))-      ( (unmerge @('(n, a) ': g1) @g2 M.** synOb @b)-          . associatorInv' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)-      )---- | The variable with id @n@: the identity on its type.-{-# INLINE var #-}-var :: forall {k} n (a :: SYN k) d. (CategoryOf k, KnownObj a) => Term d '[ '(n, a)] a-var = withSynOb @a (MkTerm (obj @(Interp a)))---- $patterns--- Wherever a function on terms receives an input, that is the function given to 'toSMC', 'lam',--- 'loop' and 'cont', the alternatives of 'with' and 'caseOf', and the left of a bind in @do@--- notation, the input arrives through a pattern: a variable, @()@, or a tuple of patterns. A--- variable stands for the whole input, whatever its type, and must be used exactly once. @()@--- matches the unit 'I'. A pair matches a tensor @a ':**' b@ and binds its two sides, and a triple--- or quadruple is pairs nested to the left, as @a ':**' b ':**' c@ is. At a computation,--- @'Up' (a ':**' b)@ or @'Up' 'I'@, a pair or @()@ pattern runs the computation and matches its--- value, so the rest of the block must be of a negative type; a variable at a computation only--- names it.------ Tuples build terms as well, the mirror image of taking them apart: 'tuple', and 'ret' of a--- tuple, make a pair at a tensor into '(**)' of its parts and a pair at a computation into the--- computation of the pair.---- | Compile a function on terms to a morphism. The function receives the input through a pattern--- (see /Patterns/), so @()@ compiles a term without inputs and a tuple takes a tensor apart.-{-# INLINE toSMC #-}-toSMC-  :: forall {k} (a :: SYN k) b t cont-   . (Monoidal k, Binds t 0 a cont '[] b)-  => (t %1 -> cont)-  -> Interp a ~> Interp b-toSMC k = case bound @0 @'[] @a @b k of MkTerm f -> f---- | Copy a term whose type is a comonoid, in "Proarrow.Tools.SMC": @(x1, x2) <- dup x@.-{-# INLINE dup #-}-dup :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s %1 -> Term d g (s :** s)-dup = lift @s @(s :** s) comult---- | Discard a term whose type is a comonoid, in "Proarrow.Tools.SMC": @() <- drop x@.-{-# INLINE drop #-}-drop :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s %1 -> Term d g I-drop = lift @s @I counit---- | Lift a morphism of the target category to a function on terms.-{-# INLINE lift #-}-lift :: forall {k} (a :: SYN k) b d g. (CategoryOf k) => (Interp a ~> Interp b) -> Term d g a %1 -> Term d g b-lift f (MkTerm t) = MkTerm (f . t)---- | A term without variables, written at depth 0, for use at any depth. A reusable piece that--- has no inputs but binds variables of its own is defined with it.-{-# INLINE closed #-}-closed :: forall {k} (a :: SYN k) d. Term 0 '[] a -> Term d '[] a-closed t = recast t---- | Use a function on terms inside another term, compiled on its own with 'toSMC', so that its--- argument is a pattern too. This is how a reusable piece that binds variables of its own is used,--- and unlike 'lift' of the compiled morphism it needs no type annotations.-{-# INLINE call #-}-call-  :: forall {k} (a :: SYN k) b d g t cont-   . (Monoidal k, Binds t 0 a cont '[] b)-  => (t %1 -> cont)-  -> Term d g a-  %1 -> Term d g b-call f = lift @a @b (toSMC @a @b f)---- | Two terms side by side. Their contexts must be disjoint.-{-# INLINE (**) #-}-(**)-  :: forall {k} d g1 g2 (a :: SYN k) b-   . (Monoidal k, Merge g1 g2)-  => Term d g1 a %1 -> Term d g2 b %1 -> Term d (Union g1 g2) (a :** b)-MkTerm f ** MkTerm g = MkTerm ((f M.** g) . merge @g1 @g2)---- | Two new variables @(n, a)@ and @(m, b)@ on the right of the context @r@, for 'split'. When @r@--- is empty the pair is the whole context.-{-# INLINE push2 #-}-push2-  :: forall {k} r n (a :: SYN k) m b g-   . (Monoidal k, KnownObj a, KnownObj b, Merge r g)-  => (Interp (Mul g) ~> Interp a ** Interp b)-  -> Interp (Mul (Union r g)) ~> Interp (Mul ('(m, b) ': '(n, a) ': r))-push2 p =-  ctxCase @r-    p-    (associatorInv' (ctxOb @r) (synOb @a) (synOb @b) . (ctxOb @r M.** p) . merge @r @g)---- | Take a tensor apart: the continuation gets a variable for each side and must use both.-{-# INLINE split #-}-split-  :: forall {k} d g r (a :: SYN k) b c da db-   . (Monoidal k, KnownObj a, KnownObj b, Merge r g)-  => Term d g (a :** b)-  %1 -> ( Term da '[ '(d, a)] a-          %1 -> Term db '[ '(d + 1, b)] b-          %1 -> Term (d + 2) ('(d + 1, b) ': '(d, a) ': r) c-        )-  %1 -> Term d (Union r g) c-split (MkTerm p) k = case k (var @d @a) (var @(d + 1) @b) of-  MkTerm body -> MkTerm (body . push2 @r @d @a @(d + 1) @b @g p)---- | The unit, which uses no variables.-{-# INLINE unit #-}-unit :: forall {k} d. (Monoidal k) => Term d ('[] :: Ctx k) I-unit = MkTerm id---- | A function: the body receives the argument through a pattern (see /Patterns/). This needs the--- category to be closed.-{-# INLINE lam #-}-lam-  :: forall {k} d r (a :: SYN k) b t cont-   . (Closed k, Binds t d a cont r b)-  => (t %1 -> cont)-  %1 -> Term d r (a :-> b)-lam k = case bound @d @r @a @b k of-  MkTerm body -> withCtxOb @r (withSynOb @a (MkTerm (curry @k @(Interp (Mul r)) @(Interp a) (body . snoc @d @a @r))))---- | The body of a binder, with the pattern taking apart its new variable: what 'toSMC', 'lam',--- 'loop' and 'cont' share, and the binds of a computation through 'runUp'.-{-# INLINE bound #-}-bound-  :: forall {k} d r (a :: SYN k) b t cont-   . (Binds t d a cont r b)-  => (t %1 -> cont)-  %1 -> Term (d + 1) ('(d, a) ': r) b-bound k = bindPat (var @d @a @(d + 1)) k---- | Trace: the body receives the value fed back through a pattern (see /Patterns/), and returns--- it again next to the result. This needs the category to be traced.-{-# INLINE loop #-}-loop-  :: forall {k} (u :: SYN k) b d r t cont-   . (TracedMonoidal k, KnownObj b, Binds t d u cont r (b :** u))-  => (t %1 -> cont)-  %1 -> Term d r b-loop k = case bound @d @r @u @(b :** u) k of-  MkTerm body ->-    withCtxOb @r-      (withSynOb @u (withSynOb @b (MkTerm (trace @(~>) @(Interp u) @(Interp (Mul r)) @(Interp b) (body . snoc @d @u @r)))))---- | A new pair of wires, a variable and its dual, from nothing: the unit of the duality. This--- needs the category to be compact closed.-{-# INLINE produce #-}-produce :: forall {k} (a :: SYN k) d. (CompactClosed k, KnownObj a) => Term d '[] (a :** Not a)-produce = withSynOb @a (MkTerm (dualityUnit @k @(Interp a)))---- | Join a dual and its wire into nothing: the counit of the duality, which an isomix category--- has.-{-# INLINE annihilate #-}-annihilate-  :: forall {k} (a :: SYN k) d g1 g2-   . (IsoMix k, KnownObj a, Merge g1 g2)-  => Consumer d g1 a %1 -> Term d g2 a %1 -> Term d (Union g1 g2) I-annihilate x y = lift @(Not a :** a) @I (withSynOb @a (dualityCounit @k @(Interp a))) (x ** y)---- $inout--- In a dialogue category, one with a tensorial negation 'Dual', a term of @'Not' a@ consumes an--- @a@: an output, seen as an input. Terms then read as in System L, the μμ̃-calculus, which treats--- the two alike. A 'Term' of @a@ produces an @a@ and a 'Consumer' of @a@, a term of @'Not' a@,--- consumes one; 'cut', or @t '|>' k@, is the two meeting, a 'Command', a term of @'Not' 'I'@; and--- 'cont' is the one binder, which receives an @a@ and runs a command with it, whether that @a@ is--- an input or the consumer of an output.------ The types have a polarity: @'Not' a@ is negative, everything else positive. A term of a negative--- type is given its consumer, so binding an output of a positive type @a@ with 'cont' gives--- @'Up' a = 'Not' ('Not' a)@, a computation that will produce an @a@, and 'ret' makes a value into--- the computation that produces it. In @do@ notation, binding a computation runs it, with the rest--- of the block, which must be negative, as what happens next; this is where terms get an--- evaluation order, which a symmetric monoidal category does not have by itself. 'Dn' is the--- shift the other way, the same object at positive polarity: 'thunk' and 'force' are identities--- on the morphism, and a bind names a @'Dn' ('Up' a)@ instead of running it. Patterns and tuples--- at a computation are described under /Patterns/.------ More structure in the category adds to this. In an isomix category a consumer and its value--- join into the unit itself rather than into @'Not' 'I'@ ('annihilate'). In a *-autonomous--- category the negation is an involution, so a computation is its value again ('classical') and--- the polarities collapse. In a compact closed category a value and its consumer can also be--- created from nothing ('produce'), which gives traces and bends wires back on themselves.---- | The shift of a positive type to a negative one: a computation that produces an @a@. A term of--- it is a consumer of consumers of @a@, so in a category with @'Dual' a = a ~~> r@ it is the--- continuation passing type @(a -> r) -> r@.-type Up :: forall {k}. SYN k -> SYN k-type Up a = Not (Not a)---- | A consumer of @a@: a term of its negation.-type Consumer :: forall {k}. Nat -> Ctx k -> SYN k -> Type-type Consumer d g a = Term d g (Not a)---- | A producer and a consumer meeting: a term of the unit of par.-type Command :: forall {k}. Nat -> Ctx k -> Type-type Command d g = Term d g (Not I)---- | Par, the negation of the tensor of the negations, interpreted as 'Proarrow.Category.Monoidal.Dialogue.Par'.-type (:##) :: forall {k}. SYN k -> SYN k -> SYN k-type a :## b = Not (Not a :** Not b)---- | A consumer meets a producer: @cut k t@ gives @t@ to @k@, like applying a continuation.-{-# INLINE cut #-}-cut-  :: forall {k} (a :: SYN k) d g1 g2-   . (Dialogue k, KnownObj a, Merge g1 g2)-  => Consumer d g1 a %1 -> Term d g2 a %1 -> Command d (Union g1 g2)-cut x y = lift @(Not a :** a) @(Not I) (withSynOb @a (dualityCounitSA @(Interp a))) (x ** y)---- | 'cut' with the producer first, as System L writes @⟨t | k⟩@: @t |> k@ sends @t@ into @k@.-{-# INLINE (|>) #-}-(|>)-  :: forall {k} (a :: SYN k) d g1 g2-   . (Dialogue k, KnownObj a, Merge g2 g1)-  => Term d g1 a %1 -> Consumer d g2 a %1 -> Command d (Union g2 g1)-t |> k = cut k t---- | The binder of System L. @cont \\x -> c@ is a term of @'Not' a@: it receives an @a@ through the--- pattern @x@ (see /Patterns/) and runs the command @c@ with it.------ What that @a@ is depends on how the result is used. As a 'Consumer' of @a@, the @a@ is an input--- and @cont@ is μ̃: the seller in a shop receives the order, @cont \\(name, card, replyTo) -> …@. As--- a term of the negative type @'Not' a@ in its own right, the @a@ is the consumer of an output and--- @cont@ is μ, Haskell's @callCC@: a computation @'Up' b@ receives the consumer of its result,--- @cont \\k -> … |> k@; a par @b ':##' c@ receives a consumer for each side, @cont \\(kb, kc) -> …@;--- and a command, @'Not' 'I'@, receives nothing, @cont \\() -> …@. A consumer of a par is a--- computation, which a nested pair pattern runs to get at the consumers of its sides.-{-# INLINE cont #-}-cont-  :: forall {k} d r (a :: SYN k) t cont-   . (Dialogue k, Binds t d a cont r (Not I))-  => (t %1 -> cont)-  %1 -> Term d r (Not a)-cont k = case bound @d @r @a @(Not I) k of-  MkTerm body ->-    withCtxOb @r-      ( withSynOb @a-          ( MkTerm-              ( dual (rightUnitorInv @k @(Interp a))-                  . linDist @k @(Interp (Mul r)) @(Interp a) @Unit (body . snoc @d @a @r)-              )-          )-      )---- | Run a computation against the rest of a block. The body is what the rest does with the value,--- given the context @r@; it becomes a consumer of the computation, whose context @g@ joins. What--- the binds of a computation share, the counterpart of 'bound'.-{-# INLINE runUp #-}-runUp-  :: forall {k} d g r (a :: SYN k) y-   . (Dialogue k, KnownObj a, KnownObj y, Merge g r)-  => Term d g (Up a)-  %1 -> (Interp (Mul r) ** Interp a ~> Interp (Not y))-  -> Term d (Union g r) (Not y)-runUp (MkTerm m) body =-  withCtxOb @r-    ( withSynOb @a-        ( withSynOb @y-            ( MkTerm-                ( bindDual @(Interp (Mul r)) @(Interp a) @(Interp y) body-                    . (m M.** obj @(Interp (Mul r)))-                    . merge @g @r-                )-            )-        )-    )---- | A value as the computation that produces it: double negation introduction, and the return of--- a @do@ block in the continuation reading. It also reads as a producer of @a@ handed over as a--- consumer of @'Not' a@. The value can be given as a 'Tuple' of terms, built by the type expected.-{-# INLINE ret #-}-ret-  :: forall {k} (a :: SYN k) t-   . (Dialogue k, KnownObj a, Tuple k t a)-  => t %1 -> Term (TupleDepth t) (TupleCtx k t) (Up a)-ret t = withSynOb @a (lift @a @(Up a) (doubleNegInv @k @(Interp a))) (tuple @k @t @a t)---- | A term built from a tuple of terms, by the type it is expected to have: a term is itself, a--- pair at a tensor is the tensor of its parts, and a pair at a computation @'Up' a@ is the--- computation of the pair at @a@. A triple or quadruple stands for pairs nested to the left, as in--- patterns. The parts must be at the same depth, and their contexts are merged.-type Tuple :: forall k -> Type -> SYN k -> Constraint-class Tuple k t a where-  tuple :: t %1 -> Term (TupleDepth t) (TupleCtx k t) a---- | The context of a tuple of terms: the union of the contexts of its parts.-type TupleCtx :: forall k -> Type -> Ctx k-type family TupleCtx k t where-  TupleCtx k (x, y) = Union (TupleCtx k x) (TupleCtx k y)-  TupleCtx k (x, y, z) = TupleCtx k ((x, y), z)-  TupleCtx k (w, x, y, z) = TupleCtx k (((w, x), y), z)-  TupleCtx k t = CtxOf @k t---- | The depth of a tuple of terms: that of its first part.-type TupleDepth :: Type -> Nat-type family TupleDepth t where-  TupleDepth (x, y) = TupleDepth x-  TupleDepth (x, y, z) = TupleDepth x-  TupleDepth (w, x, y, z) = TupleDepth w-  TupleDepth t = DepthOf t---- The generic instances are incoherent, as for patterns: a term's type is often still unknown when--- the instance is chosen, and a pair defaults to a tensor until its type is known to be an 'Up'.---- | A term is itself.-instance {-# INCOHERENT #-} (t ~ Term d g a) => Tuple k t a where-  {-# INLINE tuple #-}-  tuple t = t---- | A pair at a tensor is the tensor of its parts.-instance-  {-# INCOHERENT #-}-  ( Monoidal k-  , a ~ (a1 :** a2)-  , Tuple k x a1-  , Tuple k y a2-  , TupleDepth y ~ TupleDepth x-  , Merge (TupleCtx k x) (TupleCtx k y)-  )-  => Tuple k (x, y) (a :: SYN k)-  where-  {-# INLINE tuple #-}-  tuple (x, y) = tuple @k @x @a1 x ** tuple @k @y @a2 y---- | A pair at a computation is the computation of the pair at the value.-instance (Dialogue k, KnownObj a, Tuple k (x, y) a) => Tuple k (x, y) (Not (Not a) :: SYN k) where-  {-# INLINE tuple #-}-  tuple p = ret @a p--instance (Tuple k ((x, y), z) a) => Tuple k (x, y, z) a where-  {-# INLINE tuple #-}-  tuple (x, y, z) = tuple @k @((x, y), z) @a ((x, y), z)--instance (Tuple k (((w, x), y), z) a) => Tuple k (w, x, y, z) a where-  {-# INLINE tuple #-}-  tuple (w, x, y, z) = tuple @k @(((w, x), y), z) @a (((w, x), y), z)---- | The same morphism at another type expression for the same object, and at any depth: between--- @'F' (a '**' b)@ and @'F' a ':**' 'F' b@, say, so that a pattern can take it apart, or between a--- type and its 'Dn'. The polarity may change, the morphism does not.-{-# INLINE recast #-}-recast :: forall {k} (a :: SYN k) b d d' g. (Interp a ~ Interp b) => Term d g a %1 -> Term d' g b-recast (MkTerm f) = MkTerm f---- | Store a term of a negative type as a value: the same morphism at the positive type @'Dn' n@,--- which a bind names instead of running. This is call by push value's @thunk@, 'recast' to 'Dn'.-{-# INLINE thunk #-}-thunk :: forall {k} (n :: SYN k) d g. Term d g n %1 -> Term d g (Dn n)-thunk = recast---- | A stored term at its negative type again, where a bind runs it. This is call by push value's--- @force@, 'recast' from 'Dn'.-{-# INLINE force #-}-force :: forall {k} (n :: SYN k) d g. Term d g (Dn n) %1 -> Term d g n-force = recast---- | A computation as its value again: double negation elimination, which only a *-autonomous--- category has. There every type is equivalent to its shift, so the polarities collapse.-{-# INLINE classical #-}-classical :: forall {k} (a :: SYN k) d g. (StarAutonomous k, KnownObj a) => Term d g (Up a) %1 -> Term d g a-classical = withSynOb @a (lift @(Up a) @a (doubleNeg @k @(Interp a)))---- $additives--- The additives share their context between alternatives, of which only one is used. Terms that--- share variables can't both be written in a linear function, so the alternatives are functions of--- their own, compiled with 'toSMC' like the argument of 'call', and what they share is passed in as--- one term.---- | Both of two alternatives on the same input: the product. Each alternative receives the input--- through a pattern (see /Patterns/). This needs products.-{-# INLINE with #-}-with-  :: forall {k} (s :: SYN k) a b d g t1 cont1 t2 cont2-   . (Monoidal k, HasBinaryProducts k, Binds t1 0 s cont1 '[] a, Binds t2 0 s cont2 '[] b)-  => (t1 %1 -> cont1)-  -> (t2 %1 -> cont2)-  -> Term d g s-  %1 -> Term d g (a :&& b)-with f h = lift @s @(a :&& b) (toSMC @s @a f &&& toSMC @s @b h)---- | The first alternative of a product.-{-# INLINE exl #-}-exl-  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) %1 -> Term d g a-exl = lift @(a :&& b) @a (withSynOb @a (withSynOb @b (fst @k @(Interp a) @(Interp b))))---- | The second alternative of a product.-{-# INLINE exr #-}-exr-  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) %1 -> Term d g b-exr = lift @(a :&& b) @b (withSynOb @a (withSynOb @b (snd @k @(Interp a) @(Interp b))))---- | Use up a term into the unit of the product.-{-# INLINE absorb #-}-absorb :: forall {k} (s :: SYN k) d g. (HasTerminalObject k, KnownObj s) => Term d g s %1 -> Term d g Top-absorb = lift @s @Top (withSynOb @s (terminate @k @(Interp s)))---- | The left injection into a coproduct.-{-# INLINE inl #-}-inl-  :: forall {k} (a :: SYN k) b d g-   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)-  => Term d g a %1 -> Term d g (a :|| b)-inl = lift @a @(a :|| b) (withSynOb @a (withSynOb @b (lft @k @(Interp a) @(Interp b))))---- | The right injection into a coproduct.-{-# INLINE inr #-}-inr-  :: forall {k} (a :: SYN k) b d g-   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)-  => Term d g b %1 -> Term d g (a :|| b)-inr = lift @b @(a :|| b) (withSynOb @a (withSynOb @b (rgt @k @(Interp a) @(Interp b))))---- | Case analysis on a coproduct, given first a term to share between the branches. Both branches--- receive the pair of the shared term and the contents of their alternative through a pattern--- (see /Patterns/). This needs the tensor to distribute over the coproduct.-{-# INLINE caseOf #-}-caseOf-  :: forall {k} (s :: SYN k) a b c d g1 g2 t1 cont1 t2 cont2-   . ( Distributive k-     , KnownObj s-     , KnownObj a-     , KnownObj b-     , Merge g1 g2-     , Binds t1 0 (s :** a) cont1 '[] c-     , Binds t2 0 (s :** b) cont2 '[] c-     )-  => Term d g1 s-  %1 -> Term d g2 (a :|| b)-  %1 -> (t1 %1 -> cont1)-  -> (t2 %1 -> cont2)-  -> Term d (Union g1 g2) c-caseOf e x f h =-  lift @(s :** (a :|| b)) @c-    ( withSynOb @s-        ( withSynOb @a-            ( withSynOb @b-                ( (toSMC @(s :** a) @c f ||| toSMC @(s :** b) @c h)-                    . distL @k @(Interp s) @(Interp a) @(Interp b)-                )-            )-        )-    )-    (e ** x)---- | There is no term of 'Zero', so from one, together with the rest of the context, anything--- follows.-{-# INLINE absurd #-}-absurd-  :: forall {k} (s :: SYN k) c d g1 g2-   . (Distributive k, KnownObj s, KnownObj c, Merge g1 g2)-  => Term d g1 s %1 -> Term d g2 Zero %1 -> Term d (Union g1 g2) c-absurd e z = lift @(s :** Zero) @c (withSynOb @s (withSynOb @c (initiate @k @(Interp c) . absorbL @k @(Interp s)))) (e ** z)---- | Function application. The function and its argument must have disjoint contexts.-{-# INLINE (!) #-}-(!)-  :: forall {k} d g1 g2 (a :: SYN k) b-   . (Closed k, KnownObj a, KnownObj b, Merge g1 g2)-  => Term d g1 (a :-> b) %1 -> Term d g2 a %1 -> Term d (Union g1 g2) b-MkTerm f ! MkTerm x =-  withSynOb @a (withSynOb @b (MkTerm (apply @k @(Interp a) @(Interp b) . (f M.** x) . merge @g1 @g2)))---- Do notation---- | The pattern @t@ of a binder: it takes apart the variable @(n, a)@, and the binder's body--- @cont@ then gives a term at depth @n + 1@ with type @b@, whose context is that variable and @g@.--- Both the variable's type and the rest of the context must be known.-type Binds :: forall k. Type -> Nat -> SYN k -> Type -> Ctx k -> SYN k -> Constraint-type Binds @k t n a cont g b =-  (KnownObj a, KnownCtx g, BindPat k (Term (n + 1) '[ '(n, a)] a) t cont (Term (n + 1) ('(n, a) ': g) b))---- | A bind in a @do@ block: a term taken apart by a pattern, or the variables of a @rec@ block.--- The multiplicity @p@ of the continuation depends only on the right hand side @m@, since GHC--- needs it before it knows the rest.-type Bind :: Type -> Type -> Type -> Multiplicity -> Type -> Type -> Constraint-class Bind k m t p cont r | m -> k p where-  -- | Bind the right hand side to the pattern of the continuation.-  (>>=) :: m %1 -> (t %p -> cont) %1 -> r---- | A term on the right hand side is taken apart by the pattern. Incoherent, so that it is chosen--- as soon as the right hand side is known, unless the right hand side is a computation.-instance {-# INCOHERENT #-} (BindPat k (Term d g a) t cont r) => Bind k (Term d g (a :: SYN k)) t One cont r where-  {-# INLINE (>>=) #-}-  (>>=) = bindPat---- | A computation on the right hand side runs first, and the rest of the block is negative.-instance-  ( Dialogue k-  , KnownObj y-  , Merge g r-  , TyOf @k cont ~ Not y-  , Binds t d a cont r (Not y)-  , r' ~ Term d (Union g r) (Not y)-  )-  => Bind k (Term d g (Not (Not a))) t One cont r'-  where-  {-# INLINE (>>=) #-}-  m >>= k = case bound @d @r @a @(Not y) k of-    MkTerm body -> runUp @d @g @r @a @y m (body . snoc @d @a @r)---- | A term on the right hand side taken apart by the pattern of the continuation. The types of the--- continuation and the result are matched with equalities, so that the instance is chosen as soon--- as the right hand side is known.-type BindPat :: Type -> Type -> Type -> Type -> Type -> Constraint-class BindPat k m t cont r | m -> k where-  bindPat :: m %1 -> (t %1 -> cont) %1 -> r--instance-  ( cont ~ Term (d + PSize t) (CtxOf @k cont) (TyOf @k cont)-  , r ~ Term d (PCtx t d g a (CtxOf @k cont)) (TyOf @k cont)-  , Pat k t d g a (CtxOf @k cont) (TyOf @k cont)-  )-  => BindPat k (Term d g (a :: SYN k)) t cont r-  where-  {-# INLINE bindPat #-}-  bindPat = pat @k @t @d @g @a @(CtxOf @k cont) @(TyOf @k cont)---- | The statement of a @rec@ block, whose continuation is its 'return'.-instance-  (Bind k (Term d g a) t One cont r', r ~ Ret tt r')-  => Bind k (Term d g (a :: SYN k)) t One (Ret tt cont) r-  where-  {-# INLINE (>>=) #-}-  x >>= k = Ret (x >>= \p -> unRet (k p))---- | The body of a @rec@ block, tagged with the tuple of its variables. GHC's translation passes--- that tuple to both 'return' and 'mfix', and this tag is what makes them the same.-type Ret :: Type -> Type -> Type-newtype Ret t x = Ret x--unRet :: Ret t x %1 -> x-unRet (Ret x) = x---- | A pattern: a variable, @()@, or a pair of patterns. A triple or quadruple stands for pairs--- nested to the left, as @a ':**' b ':**' c@ is: @(x, y, z)@ is @((x, y), z)@. Binding it at depth--- @d@ to a term with context @g@ and type @a@, with a continuation with context @g'@ and type @c@.--- A pair or @()@ at a computation, @'Up' a@, runs it and matches its value, so @c@ is then negative.-type Pat :: forall k -> Type -> Nat -> Ctx k -> SYN k -> Ctx k -> SYN k -> Constraint-class Pat k t d g a g' c where-  pat :: Term d g a %1 -> (t %1 -> Term (d + PSize t) g' c) %1 -> Term d (PCtx t d g a g') c---- | The number of variables a pattern binds on the way, and so the depth it adds.-type PSize :: Type -> Nat-type family PSize t where-  PSize (x, y) = 2 + PSize x + PSize y-  PSize (x, y, z) = PSize ((x, y), z)-  PSize (w, x, y, z) = PSize (((w, x), y), z)-  PSize t = 0---- | The context of a pattern match, from the context of the right hand side and of the--- continuation.-type PCtx :: forall {k}. Type -> Nat -> Ctx k -> SYN k -> Ctx k -> Ctx k-type family PCtx t d g a g' where-  PCtx (x, y) d g (Not (Not a)) g' = Union g (Tail (PCtx (x, y) d '[ '(d, a)] a g'))-  PCtx (x, y) d g (a1 :** a2) g' = Union (Drop2 (PCtxPair x y d a1 a2 g')) g-  PCtx (x, y, z) d g a g' = PCtx ((x, y), z) d g a g'-  PCtx (w, x, y, z) d g a g' = PCtx (((w, x), y), z) d g a g'-  PCtx () d g a g' = Union g g'-  PCtx t d g a g' = g'---- | The context of the body of the 'split' that a pair pattern starts with.-type PCtxPair :: forall {k}. Type -> Type -> Nat -> SYN k -> SYN k -> Ctx k -> Ctx k-type PCtxPair x y d a1 a2 g' =-  PCtx x (d + 2) '[ '(d, a1)] a1 (PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g')---- The generic instances are incoherent: a variable pattern's type is often still unknown when the--- instance is chosen, and a pair pattern's type is always a pair by then. The instances at a--- computation are more specific, so they win once the type is known to be an 'Up'.---- | The pattern @()@ at a computation of the unit runs it.-instance (Dialogue k, KnownObj y, c ~ Not y, Merge g g') => Pat k () d g (Not (Not I) :: SYN k) g' c where-  {-# INLINE pat #-}-  pat u k = case k () of-    MkTerm t -> runUp @d @g @g' @I @y u (withCtxOb @g' (t . rightUnitor @k @(Interp (Mul g'))))---- | A pair pattern at a computation runs it and takes its value apart. The value needs no variable--- of its own: the pattern's variables take the ids it would have taken.-instance-  ( Dialogue k-  , KnownObj a-  , KnownObj y-  , c ~ Not y-  , Pat k (x, y') d '[ '(d, a)] a g' c-  , PCtx (x, y') d '[ '(d, a)] a g' ~ ('(d, a) ': r)-  , Merge g r-  )-  => Pat k (x, y') d g (Not (Not a) :: SYN k) g' c-  where-  {-# INLINE pat #-}-  pat m k = case pat @k @(x, y') @d @'[ '(d, a)] @a @g' @c (var @d @a @d) k of-    MkTerm body -> runUp @d @g @r @a @y m (body . snoc @d @a @r)---- | The pattern @()@ uses up a term of the unit type.-instance {-# INCOHERENT #-} (Monoidal k, a ~ I, KnownObj c, Merge g g') => Pat k () d g (a :: SYN k) g' c where-  {-# INLINE pat #-}-  pat (MkTerm u) k = case k () of-    MkTerm t -> withSynOb @c (MkTerm (leftUnitor @k @(Interp c) . (u M.** t) . merge @g @g'))--instance {-# INCOHERENT #-} (t ~ Term (DepthOf t) g a) => Pat k t d g a g' c where-  {-# INLINE pat #-}-  pat x k = k (recast x)--instance-  {-# INCOHERENT #-}-  ( Monoidal k-  , a ~ (a1 :** a2)-  , KnownObj a1-  , KnownObj a2-  , Pat k x (d + 2) '[ '(d, a1)] a1 (PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g') c-  , Pat k y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g' c-  , d + 2 + PSize x + PSize y ~ d + PSize (x, y)-  , PCtxPair x y d a1 a2 g' ~ ('(d + 1, a2) ': '(d, a1) ': Drop2 (PCtxPair x y d a1 a2 g'))-  , Merge (Drop2 (PCtxPair x y d a1 a2 g')) g-  )-  => Pat k (x, y) d g (a :: SYN k) g' c-  where-  {-# INLINE pat #-}-  pat s k =-    split-      s-      ( \a b ->-          pat @k @x @(d + 2) @'[ '(d, a1)] @a1 @(PCtx y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g') @c-            a-            (\px -> pat @k @y @(d + 2 + PSize x) @'[ '(d + 1, a2)] @a2 @g' @c b (\py -> k (px, py)))-      )--instance {-# INCOHERENT #-} (Pat k ((x, y), z) d g a g' c) => Pat k (x, y, z) d g a g' c where-  {-# INLINE pat #-}-  pat s k = pat @k @((x, y), z) @d @g @a @g' @c s (\((px, py), pz) -> k (px, py, pz))--instance {-# INCOHERENT #-} (Pat k (((w, x), y), z) d g a g' c) => Pat k (w, x, y, z) d g a g' c where-  {-# INLINE pat #-}-  pat s k = pat @k @(((w, x), y), z) @d @g @a @g' @c s (\(((pw, px), py), pz) -> k (pw, px, py, pz))---- | The variables of a @rec@ block, as GHC tuples them up.-type RecVars :: Type -> Type -> Constraint-class RecVars k t | t -> k where-  type Vars k t :: Ctx k-  recVars :: t-  consume :: t %1 -> r %1 -> r--instance (Monoidal k, KnownObj (a :: SYN k)) => RecVars k (Term d '[ '(n, a)] a) where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (Term d '[ '(n, a)] a) = '[ '(n, a)]-  recVars = var @n @a-  consume (MkTerm _) r = r--instance (RecVars k x, RecVars k y) => RecVars k (x, y) where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (x, y) = Union (Vars k x) (Vars k y)-  recVars = (recVars, recVars)-  consume (x, y) r = consume x (consume y r)--instance (RecVars k x, RecVars k y, RecVars k z) => RecVars k (x, y, z) where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (x, y, z) = Union (Vars k x) (Vars k (y, z))-  recVars = (recVars, recVars, recVars)-  consume (x, y, z) r = consume x (consume (y, z) r)--instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w) => RecVars k (x, y, z, w) where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (x, y, z, w) = Union (Vars k x) (Vars k (y, z, w))-  recVars = (recVars, recVars, recVars, recVars)-  consume (x, y, z, w) r = consume x (consume (y, z, w) r)--instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v) => RecVars k (x, y, z, w, v) where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (x, y, z, w, v) = Union (Vars k x) (Vars k (y, z, w, v))-  recVars = (recVars, recVars, recVars, recVars, recVars)-  consume (x, y, z, w, v) r = consume x (consume (y, z, w, v) r)--instance-  (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v, RecVars k u)-  => RecVars k (x, y, z, w, v, u)-  where-  {-# INLINE recVars #-}-  {-# INLINE consume #-}-  type Vars k (x, y, z, w, v, u) = Union (Vars k x) (Vars k (y, z, w, v, u))-  recVars = (recVars, recVars, recVars, recVars, recVars, recVars)-  consume (x, y, z, w, v, u) r = consume x (consume (y, z, w, v, u) r)---- | The end of a @rec@ block: all its variables, as the tensor of their context.-{-# INLINE return #-}-return-  :: forall k t d. (Monoidal k, RecVars k t, KnownCtx (Vars k t)) => t %1 -> Ret t (Term d (Vars k t) (Mul (Vars k t)))-return t = Ret (consume t (MkTerm (ctxOb @(Vars k t))))---- | A @rec@ block after tracing, from its context without the fed back variables to the variables--- it passes on.-type Rec :: forall {k}. Nat -> Type -> Ctx k -> Ctx k -> Type-data Rec d t g0 outs where-  Rec :: (Interp (Mul g0) ~> Interp (Mul outs)) -> Rec d t g0 outs---- | Trace a @rec@ block: the variables it uses before binding them are fed back.-{-# INLINE mfix #-}-mfix-  :: forall {k} t d (g :: Ctx k)-   . ( TracedMonoidal k-     , RecVars k t-     , Merge (Inter g (Vars k t)) (Minus g (Vars k t))-     , Merge (Inter g (Vars k t)) (Minus (Vars k t) g)-     , Union (Inter g (Vars k t)) (Minus g (Vars k t)) ~ g-     , Union (Inter g (Vars k t)) (Minus (Vars k t) g) ~ Vars k t-     )-  => (t -> Ret t (Term d g (Mul (Vars k t)))) %1 -> Rec d t (Minus g (Vars k t)) (Minus (Vars k t) g)-mfix f = case unRet (f recVars) of-  MkTerm body ->-    withCtxOb @(Inter g (Vars k t))-      ( withCtxOb @(Minus g (Vars k t))-          ( withCtxOb @(Minus (Vars k t) g)-              ( Rec-                  ( coact-                      @Tensor-                      @(~>)-                      @(Interp (Mul (Inter g (Vars k t))))-                      @(Interp (Mul (Minus g (Vars k t))))-                      @(Interp (Mul (Minus (Vars k t) g)))-                      ( merge @(Inter g (Vars k t)) @(Minus (Vars k t) g)-                          . body-                          . unmerge @(Inter g (Vars k t)) @(Minus g (Vars k t))-                      )-                  )-              )-          )-      )---- | The rest of the @do@ block after a @rec@ block. GHC binds the variables of the block here--- without linearity, so the context checks see to it that the ones passed on are used once and--- the fed back ones not at all.-instance-  ( SymMonoidal k-  , RecVars k t-  , t' ~ t-  , cont ~ Term (HeadId (Vars k t) + 1) (CtxOf @k cont) (TyOf @k cont)-  , r ~ Term d (Union (Minus (CtxOf @k cont) outs) g0) (TyOf @k cont)-  , AllIn outs (CtxOf @k cont)-  , NoneIn (Minus (CtxOf @k cont) outs) (Vars k t)-  , Merge (Minus (CtxOf @k cont) outs) g0-  , Merge (Minus (CtxOf @k cont) outs) outs-  , CtxOf @k cont ~ Union (Minus (CtxOf @k cont) outs) outs-  )-  => Bind k (Rec d t (g0 :: Ctx k) outs) t' Many cont r-  where-  {-# INLINE (>>=) #-}-  Rec h >>= k = case k recVars of-    MkTerm body ->-      MkTerm-        ( body-            . unmerge @(Minus (CtxOf @k cont) outs) @outs-            . (ctxOb @(Minus (CtxOf @k cont) outs) M.** h)-            . merge @(Minus (CtxOf @k cont) outs) @g0-        )---- | GHC's translation of @rec@ refers to @fail@, but pairs of variables always match.-fail :: a-fail = P.error "Proarrow.Tools.SMC.fail: a pattern did not match"--type DepthOf :: Type -> Nat-type family DepthOf t where-  DepthOf (Term d g a) = d--type CtxOf :: forall k. Type -> Ctx k-type family CtxOf t where-  CtxOf (Term d g a) = g--type TyOf :: forall k. Type -> SYN k-type family TyOf t where-  TyOf (Term d g a) = a--type Drop2 :: forall {k}. Ctx k -> Ctx k-type Drop2 g = Tail (Tail g)--type Tail :: forall {k}. Ctx k -> Ctx k-type family Tail g where-  Tail (x ': g) = g--type HeadId :: forall {k}. Ctx k -> Nat-type family HeadId g where-  HeadId ('(n, a) ': g) = n---- | Every variable of the first context is in the second.-type AllIn :: forall {k}. Ctx k -> Ctx k -> Constraint-type AllIn g h = IsEmpty (Text "Proarrow.Tools.SMC: a variable bound in a rec block is not used") (Minus g h)---- | No variable of the first context is in the second.-type NoneIn :: forall {k}. Ctx k -> Ctx k -> Constraint-type NoneIn g h =-  IsEmpty (Text "Proarrow.Tools.SMC: a variable fed back in a rec block is also used after it") (Inter g h)--type IsEmpty :: forall {k}. ErrorMessage -> Ctx k -> Constraint-type family IsEmpty msg g where-  IsEmpty msg '[] = ()-  IsEmpty msg g = TypeError msg---- | The variables of @g@ whose ids are not in @h@.-type Minus :: forall {k}. Ctx k -> Ctx k -> Ctx k-type family Minus g h where-  Minus '[] h = '[]-  Minus g '[] = g-  Minus ('(n, a) ': g) ('(m, b) ': h) = MinusBy (CmpNat n m) ('(n, a) ': g) ('(m, b) ': h)--type MinusBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k-type family MinusBy o g h where-  MinusBy GT (x ': g) h = x ': Minus g h-  MinusBy EQ (x ': g) (y ': h) = Minus g h-  MinusBy LT g (y ': h) = Minus g h---- | The variables of @g@ whose ids are in @h@.-type Inter :: forall {k}. Ctx k -> Ctx k -> Ctx k-type Inter g h = Minus g (Minus g h)---- $--- The examples below are compiled at @k = 'Data.Kind.Type'@, where the result can be run.---- | Swap a tensor.------ >>> import Prelude (Bool (..))--- >>> swapT @Bool @Bool (True, False)--- (False,True)-swapT :: forall {k} (a :: k) b. (SymMonoidal k, Ob a, Ob b) => a ** b ~> b ** a-swapT = toSMC @(F a :** F b) \(a, b) -> b ** a---- | Apply a function to an argument, both in a tensor.------ >>> import Prelude (Bool (..), not)--- >>> applyT @Bool @Bool (not, True)--- False-applyT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => (a ~~> b) ** a ~> b-applyT = toSMC @((F a :-> F b) :** F a) (\p -> split p (\f x -> f ! x))---- | Curry the tensor.------ >>> import Prelude (Bool (..))--- >>> curryT @Bool @Bool True False--- (True,False)-curryT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => a ~> b ~~> a ** b-curryT = toSMC @(F a) @(F b :-> F a :** F b) (\x -> lam (\y -> x ** y))---- | Rotate a triple, with a triple pattern.------ >>> import Prelude (Bool (..), Int)--- >>> rotT @Int @Bool @Int ((1, True), 2)--- ((True,2),1)-rotT :: forall {k} (a :: k) b c. (SymMonoidal k, Ob a, Ob b, Ob c) => a ** b ** c ~> b ** c ** a-rotT = toSMC @(F a :** F b :** F c) \(a, b, c) -> b ** c ** a---- | Trace out @u@ with a @rec@ block. In 'Data.Kind.Type' the trace is a lazy fixed point.------ >>> import Prelude (Int, take)--- >>> traceT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1--- [1,1,1]-traceT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b-traceT h = toSMC @(F a) \a -> Proarrow.Tools.SMC.do-  rec (b, u) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)-  b---- | Trace out @u@ with 'loop'.------ >>> import Prelude (Int, take)--- >>> loopT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1--- [1,1,1]-loopT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b-loopT h = toSMC @(F a) \a -> loop @(F u) \u -> lift @(F a :** F u) @(F b :** F u) h (a ** u)---- | A trace from the duality alone, so for any compact closed category: feed @u@ in along one--- end of a new pair and join its new value with the other end.-loopCC :: forall {k} (a :: k) b u. (CompactClosed k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b-loopCC h = toSMC @(F a) \a -> Proarrow.Tools.SMC.do-  (u, u') <- produce-  (b, v) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)-  () <- annihilate u' v-  b---- | A snake: create a pair, join its dual with the input, and continue with the other end. By the--- zigzag law it is the identity. The input is older than the pair, so it sits to the left of it,--- and the join needs a swap.-snakeT :: forall {k} (a :: k). (CompactClosed k, Ob a) => a ~> a-snakeT = toSMC @(F a) \x -> Proarrow.Tools.SMC.do-  (a, a') <- produce-  () <- annihilate a' x-  a---- | The inverse of 'distribDual': make a pair for @a ** b@, and annihilate the two halves of its--- plain end with the given duals.-combineDualT :: forall {k} (a :: k) b. (CompactClosed k, Ob a, Ob b) => Dual a ** Dual b ~> Dual (a ** b)-combineDualT = toSMC @(Not (F a) :** Not (F b)) @(Not (F a :** F b)) \(da, db) -> Proarrow.Tools.SMC.do-  (ab, ab') <- produce-  (a, b) <- ab-  () <- annihilate da a-  () <- annihilate db b-  ab'---- | The tensor distributes over the coproduct: the shared @a@ goes to whichever branch is taken.------ >>> import Prelude (Bool (..), Char, Either (..), Int)--- >>> distT @Int @Bool @Char (1, Left True)--- Left (1,True)-distT-  :: forall {k} (a :: k) b c. (Distributive k, SymMonoidal k, Ob a, Ob b, Ob c) => a ** (b || c) ~> (a ** b) || (a ** c)-distT = toSMC @(F a :** (F b :|| F c)) \(a, bc) ->-  caseOf a bc (\(a', b) -> inl (a' ** b)) (\(a', c) -> inr (a' ** c))---- | Swap a coproduct, with nothing to share.------ >>> import Prelude (Bool (..), Either (..), Int)--- >>> swapEitherT @Int @Bool (Left 1)--- Right 1-swapEitherT :: forall {k} (a :: k) b. (Distributive k, SymMonoidal k, Ob a, Ob b) => a || b ~> b || a-swapEitherT = toSMC @(F a :|| F b) \x ->-  caseOf unit x (\((), a) -> inr a) (\((), b) -> inl b)---- | A pair both as it is and swapped: each alternative takes the same pair apart in its own way.------ >>> import Prelude (Bool (..), Int)--- >>> bothWaysT @Int @Bool (1, True)--- ((1,True),(True,1))-bothWaysT-  :: forall {k} (a :: k) b. (SymMonoidal k, HasBinaryProducts k, Ob a, Ob b) => a ** b ~> (a ** b) && (b ** a)-bothWaysT = toSMC @(F a :** F b) \p -> with (\q -> q) (\(x, y) -> y ** x) p---- | Double negation introduction: a consumer of a consumer of @a@ hands it the @a@. This is--- 'ret', written out.-dniT :: forall {k} (a :: k). (Dialogue k, Ob a) => a ~> Dual (Dual a)-dniT = toSMC @(F a) @(Up (F a)) \x -> cont (x |>)---- | Double negation elimination, the classical direction: a computation is its value. Binding its--- consumer with 'cont' and cutting would only give the computation back.-dneT :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual (Dual a) ~> a-dneT = toSMC @(Up (F a)) @(F a) \nn -> classical nn---- | Sequencing: run the input computation, and continue with @f@ on its value. In a category with--- @'Dual' a = a ~~> r@ this is the bind of the continuation monad.-bindT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> Dual (Dual b)) -> Dual (Dual a) ~> Dual (Dual b)-bindT f = toSMC @(Up (F a)) @(Up (F b)) \m -> Proarrow.Tools.SMC.do-  x <- m-  lift @(F a) @(Up (F b)) f x---- | Contraposition: a consumer of @b@ consumes @a@ through @f@.-contraT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> b) -> Dual b ~> Dual a-contraT f = toSMC @(Not (F b)) @(Not (F a)) \nb -> cont \x -> cut nb (lift @(F a) @(F b) f x)---- | Par is symmetric: bind both outputs and hand them to the input the other way round. This is--- 'Proarrow.Category.Monoidal.Dialogue.parSwap'.-parSwapT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => Par a b ~> Par b a-parSwapT = toSMC @(F a :## F b) @(F b :## F a) \p -> cont \(kb, ka) -> ka ** kb |> p---- | Linear (weak) distributivity, @a ⊗ (b ⅋ c) ⊸ (a ⊗ b) ⅋ c@: the @b@ the input emits is paired--- with @a@ and sent to the first output, and its @c@ goes to the second. This is--- 'Proarrow.Category.Monoidal.Dialogue.weakDistL'.-weakDistT-  :: forall {k} (a :: k) b c-   . (Dialogue k, Ob a, Ob b, Ob c)-  => a ** Par b c ~> Par (a ** b) c-weakDistT = toSMC @(F a :** (F b :## F c)) @((F a :** F b) :## F c) \(a, bc) ->-  cont \(kab, kc) -> cont (\b -> a ** b |> kab) ** kc |> bc---- | The snake on the dual: join the input with the first end of a new pair, and continue with the--- second. Here the wires meet in the order they come, so no swap is needed.-snakeDualT :: forall {k} (a :: k). (CompactClosed k, Ob a) => Dual a ~> Dual a-snakeDualT = toSMC @(Not (F a)) \x -> Proarrow.Tools.SMC.do-  (a, a') <- produce-  () <- annihilate x a-  a'+-- | A HOAS front end for building morphisms in any symmetric monoidal category, the+-- resource-aware counterpart of "Proarrow.Tools.CCC", which grows with the structure of the target: traces,+-- duals, additives, and the polarised System L reading of inputs and outputs in a dialogue+-- category. A 'Term' is indexed by its context, the variables it uses, so a variable is the+-- identity on its own type. Terms combine by merging their contexts, which reorders wires. A+-- variable used exactly once needs nothing more. One that two terms both use is copied, which needs+-- a 'Proarrow.Monoid.CocommutativeComonoid' on its type, and one that its binder's body does not use is discarded,+-- which needs a 'Proarrow.Monoid.Comonoid'. So the types ask for copying and discarding only where a term does it.+--+-- Copying a variable copies the value it stands for. A Haskell function that uses its argument+-- twice uses the term it is given twice, so in a category where copying is not natural, a term to+-- be shared should be bound to a variable first, with a bind in @do@ notation.+--+-- A variable's type records the binding depth at which it is used, so a variable used both outside+-- and inside a binder needs 'recast' at the inner use: @x ** lam (\\z -> recast x ** z)@.+--+-- Types are 'SYN' expressions, interpreted in the target category by 'Interp'. Their tensor is a+-- constructor, so a pattern can take a term's type apart, which the target's own @**@, a type+-- family, would not allow.+--+-- Every variable has an id, the number of binders around it, and a context lists its variables+-- by descending id. Merging compares ids, so it only reduces where the depths are known, which is+-- the case for terms built directly inside 'toSMC'. A reusable piece is compiled on its own with+-- 'toSMC' and used with 'lift', with no inputs from @'I'@. 'toSMC' starts again at depth 0, so it+-- must not be used inside another term: a variable of that term used in it could be taken for one+-- of its own. Inside a term, bind with @do@ notation instead.+--+-- The module also provides @do@ notation, for use with @QualifiedDo@, and with @RecursiveDo@ a+-- @rec@ block traces, which needs a traced monoidal category. Composition in the Int construction+-- ("Proarrow.Category.Instance.IntConstruction") uses both: the two morphisms run side by side,+-- and the wires each needs from the other are fed back.+--+-- > import Proarrow.Tools.SMC (SYN (..), lift, toSMC, (**))+-- > import Proarrow.Tools.SMC qualified as SMC+-- >+-- > Int @bp @bm @cp @cm f . Int @ap @am g =+-- >   Int $ toSMC @(F ap :** F cm) \x -> SMC.do+-- >     let g' = lift @(F ap :** F bm) @(F am :** F bp) g+-- >         f' = lift @(F bp :** F cm) @(F bm :** F cp) f+-- >     (ap, cm) <- x+-- >     rec ((am, bp), (bm, cp)) <- g' (ap ** bm) ** f' (bp ** cm)+-- >     am ** cp+--+-- A bind takes its right hand side apart with a pattern, see /Patterns/ below. In a @rec@ block,+-- the variables that the block itself uses, @bm@ and @bp@ above, are fed back, and the ones the+-- rest of the @do@ block uses are passed on to it. A variable that both use is copied, and one that+-- neither uses is discarded. GHC's translation of @rec@ passes every variable of the block to its end again,+-- including the ones a later statement of the block already used, so only such blocks work where+-- no statement uses a variable bound by an earlier one. A block of a single statement always+-- qualifies, and a nested pattern lets one statement bind everything, as above. 'loop' traces+-- without GHC's translation, so it has neither restriction, but the type of the fed back variable+-- has to be given.+--+-- The module is inspired by Bernardy and Spiwack,+-- [Evaluating Linear Functions to Symmetric Monoidal Categories](https://arxiv.org/abs/2103.06195), whose+-- @P k r a@ ports correspond to 'Term', @encode@ to 'lift', @decode@ to 'toSMC', @(!:)@ to+-- '(**)' and @split@ to 'split'. Unlike their implementation, it keeps the context thinned instead+-- of computing in the cartesian structure and arguing afterwards that the result is monoidal.+module Proarrow.Tools.SMC+  ( -- * Types+    SYN (..)+  , Interp+  , KnownObj++    -- * Patterns+    -- $patterns++    -- * Terms++    -- ** Symmetric monoidal categories+  , Term+  , toSMC+  , lift+  , unit+  , (**)+  , split+  , Tuple+  , TupleCtx+  , TupleDepth+  , recast++    -- ** Closed categories+  , lam+  , (!)++    -- ** CopyDiscard / Comonoids+  , dup+  , drop++    -- ** Traced monoidal categories+  , loop++    -- * Inputs and outputs+    -- $inout++    -- ** Dialogue categories+  , Up+  , Consumer+  , Command+  , type (:##)+  , cont+  , cut+  , (|>)+  , ret+  , thunk+  , force++    -- ** Isomix categories+  , annihilate++    -- ** *-autonomous categories+  , classical++    -- ** Compact closed categories+  , produce++    -- ** Hypergraph categories: index notation+    -- $index+  , sumOver+  , delta+  , (*^)+  , (^*)++    -- * Additives+    -- $additives+  , with+  , exl+  , exr+  , absorb+  , inl+  , inr+  , caseOf+  , absurd++    -- * Contexts+  , Ctx+  , KnownCtx+  , Union+  , Merge+  , Thin+  , BindVar++    -- * Do notation+  , (>>=)+  , return+  , mfix+  , fail+  , Bind+  , Binds+  ) where++import Proarrow.Tools.SMC.Internal.Additive+import Proarrow.Tools.SMC.Internal.Closed+import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Dialogue+import Proarrow.Tools.SMC.Internal.Do+import Proarrow.Tools.SMC.Internal.Frobenius+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++-- $patterns+-- Wherever a function on terms receives an input, that is the function given to 'toSMC', 'lam',+-- 'loop' and 'cont', the alternatives of 'with' and 'caseOf', and the left of a bind in @do@+-- notation, the input arrives through a pattern: a variable, @()@, or a tuple of patterns. A+-- variable stands for the whole input, whatever its type, and is discarded if it is not used. @()@+-- matches the unit 'I'. A pair matches a tensor @a ':**' b@ and binds its two sides, and a triple+-- or quadruple is pairs nested to the left, as @a ':**' b ':**' c@ is. At a computation,+-- @'Up' (a ':**' b)@ or @'Up' 'I'@, a pair or @()@ pattern runs the computation and matches its+-- value, so the rest of the block must be of a negative type; a variable at a computation only+-- names it.+--+-- Tuples build terms as well, the mirror image of taking them apart: 'ret' of a tuple makes a pair+-- at a tensor into '(**)' of its parts and a pair at a computation into the computation of the+-- pair.++-- $index+-- Index notation, as in Einstein summation, for a category whose index types are special+-- commutative Frobenius algebras, such as a hypergraph category. An index is a variable whose type+-- is such an object. Using an index more than once copies it, so every use sees the same value,+-- and 'sumOver' binds an index that is summed over. 'delta' says that two wires carry the same+-- value, which is how a morphism lifted onto an index is tied to another index: in "Proarrow.Category.Instance.Mat",+-- @'delta' ('lift' f i) j@ is the entry of @f@ at @i@ and @j@. A term of type 'I' is a scalar, and+-- @(*^)@ and @(^*)@ multiply a term by one. An output index is a summed index that the term also+-- returns, so matrix multiplication is 'Proarrow.Tools.SMC.Examples.matMulT':+--+-- > \i -> sumOver \k -> sumOver \j -> delta (lift f i) j *^ delta (lift g j) k *^ k+--+-- What the sum is depends on the category: in 'Proarrow.Category.Instance.Mat.Mat' it is the sum+-- of numbers, in 'Proarrow.Category.Instance.FinRel.FinRel' it is "there is", and in the diagram+-- categories it is a wire with no end on the boundary.++-- $inout+-- In a dialogue category, one with a tensorial negation 'Dual', a term of @'Not' a@ consumes an+-- @a@: an output, seen as an input. Terms then read as in System L, the μμ̃-calculus, which treats+-- the two alike. A 'Term' of @a@ produces an @a@ and a 'Consumer' of @a@, a term of @'Not' a@,+-- consumes one; 'cut', or @t '|>' k@, is the two meeting, a 'Command', a term of @'Not' 'I'@; and+-- 'cont' is the one binder, which receives an @a@ and runs a command with it, whether that @a@ is+-- an input or the consumer of an output.+--+-- The types have a polarity: @'Not' a@ is negative, everything else positive. A term of a negative+-- type is given its consumer, so binding an output of a positive type @a@ with 'cont' gives+-- @'Up' a = 'Not' ('Not' a)@, a computation that will produce an @a@, and 'ret' makes a value into+-- the computation that produces it. In @do@ notation, binding a computation runs it, with the rest+-- of the block, which must be negative, as what happens next; this is where terms get an+-- evaluation order, which a symmetric monoidal category does not have by itself. 'Dn' is the+-- shift the other way, the same object at positive polarity: 'thunk' and 'force' are identities+-- on the morphism, and a bind names a @'Dn' ('Up' a)@ instead of running it. Patterns and tuples+-- at a computation are described under /Patterns/.+--+-- More structure in the category adds to this. In an isomix category a consumer and its value+-- join into the unit itself rather than into @'Not' 'I'@ ('annihilate'). In a *-autonomous+-- category the negation is an involution, so a computation is its value again ('classical') and+-- the polarities collapse. In a compact closed category a value and its consumer can also be+-- created from nothing ('produce'), which gives traces and bends wires back on themselves.++-- $additives+-- The additives share their context between alternatives, of which only one is used, so a+-- variable that several alternatives use is not copied. One that an alternative does not use is+-- discarded there.
+ src/Proarrow/Tools/SMC/Examples.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}++-- | Examples of "Proarrow.Tools.SMC". They are compiled at @k = 'Data.Kind.Type'@, where the result+-- can be run.+module Proarrow.Tools.SMC.Examples+  ( swapT+  , applyT+  , curryT+  , rotT+  , traceT+  , loopT+  , loopCC+  , snakeT+  , combineDualT+  , distT+  , swapEitherT+  , bothWaysT+  , dniT+  , dneT+  , bindT+  , contraT+  , parSwapT+  , weakDistT+  , matMulT+  , traceIdxT+  , hadamardT+  , snakeDualT+  ) where++import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal)+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), Par)+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.Hypergraph (Frobenius)+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Category.Monoidal.Strength (TracedMonoidal)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Core (CategoryOf (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))++import Proarrow.Tools.SMC+import Proarrow.Tools.SMC qualified as SMC++-- | Swap a tensor.+--+-- >>> import Prelude (Bool (..))+-- >>> swapT @Bool @Bool (True, False)+-- (False,True)+swapT :: forall {k} (a :: k) b. (SymMonoidal k, Ob a, Ob b) => a ** b ~> b ** a+swapT = toSMC @(F a :** F b) \(a, b) -> b ** a++-- | Apply a function to an argument, both in a tensor.+--+-- >>> import Prelude (Bool (..), not)+-- >>> applyT @Bool @Bool (not, True)+-- False+applyT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => (a ~~> b) ** a ~> b+applyT = toSMC @((F a :-> F b) :** F a) (\p -> split p (\f x -> f ! x))++-- | Curry the tensor.+--+-- >>> import Prelude (Bool (..))+-- >>> curryT @Bool @Bool True False+-- (True,False)+curryT :: forall {k} (a :: k) b. (Closed k, SymMonoidal k, Ob a, Ob b) => a ~> b ~~> a ** b+curryT = toSMC @(F a) @(F b :-> F a :** F b) (\x -> lam (\y -> x ** y))++-- | Rotate a triple, with a triple pattern.+--+-- >>> import Prelude (Bool (..), Int)+-- >>> rotT @Int @Bool @Int ((1, True), 2)+-- ((True,2),1)+rotT :: forall {k} (a :: k) b c. (SymMonoidal k, Ob a, Ob b, Ob c) => a ** b ** c ~> b ** c ** a+rotT = toSMC @(F a :** F b :** F c) \(a, b, c) -> b ** c ** a++-- | Trace out @u@ with a @rec@ block. In 'Data.Kind.Type' the trace is a lazy fixed point.+--+-- >>> import Prelude (Int, take)+-- >>> traceT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1+-- [1,1,1]+traceT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+traceT h = toSMC @(F a) \a -> SMC.do+  rec (b, u) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)+  b++-- | Trace out @u@ with 'loop'.+--+-- >>> import Prelude (Int, take)+-- >>> loopT @Int @[Int] @[Int] (\(a, u) -> (take 3 u, a : u)) 1+-- [1,1,1]+loopT :: forall {k} (a :: k) b u. (TracedMonoidal k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+loopT h = toSMC @(F a) \a -> loop @(F u) \u -> lift @(F a :** F u) @(F b :** F u) h (a ** u)++-- | A trace from the duality alone, so for any compact closed category: feed @u@ in along one+-- end of a new pair and join its new value with the other end.+loopCC :: forall {k} (a :: k) b u. (CompactClosed k, Ob a, Ob b, Ob u) => (a ** u ~> b ** u) -> a ~> b+loopCC h = toSMC @(F a) \a -> SMC.do+  (u, u') <- produce+  (b, v) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)+  () <- annihilate u' v+  b++-- | A snake: create a pair, join its dual with the input, and continue with the other end. By the+-- zigzag law it is the identity. The input is older than the pair, so it sits to the left of it,+-- and the join needs a swap.+snakeT :: forall {k} (a :: k). (CompactClosed k, Ob a) => a ~> a+snakeT = toSMC @(F a) \x -> SMC.do+  (a, a') <- produce+  () <- annihilate a' x+  a++-- | The inverse of 'distribDual': make a pair for @a ** b@, and annihilate the two halves of its+-- plain end with the given duals.+combineDualT :: forall {k} (a :: k) b. (CompactClosed k, Ob a, Ob b) => Dual a ** Dual b ~> Dual (a ** b)+combineDualT = toSMC @(Not (F a) :** Not (F b)) @(Not (F a :** F b)) \(da, db) -> SMC.do+  (ab, ab') <- produce+  (a, b) <- ab+  () <- annihilate da a+  () <- annihilate db b+  ab'++-- | The tensor distributes over the coproduct: the shared @a@ goes to whichever branch is taken.+--+-- >>> import Prelude (Bool (..), Char, Either (..), Int)+-- >>> distT @Int @Bool @Char (1, Left True)+-- Left (1,True)+distT+  :: forall {k} (a :: k) b c. (Distributive k, SymMonoidal k, Ob a, Ob b, Ob c) => a ** (b || c) ~> (a ** b) || (a ** c)+distT = toSMC @(F a :** (F b :|| F c)) \(a, bc) ->+  caseOf bc (\b -> inl (a ** b)) (\c -> inr (a ** c))++-- | Swap a coproduct, with nothing to share.+--+-- >>> import Prelude (Bool (..), Either (..), Int)+-- >>> swapEitherT @Int @Bool (Left 1)+-- Right 1+swapEitherT :: forall {k} (a :: k) b. (Distributive k, SymMonoidal k, Ob a, Ob b) => a || b ~> b || a+swapEitherT = toSMC @(F a :|| F b) \x -> caseOf x (\a -> inr a) (\b -> inl b)++-- | A pair both as it is and swapped: the second alternative takes the pair apart.+--+-- >>> import Prelude (Bool (..), Int)+-- >>> bothWaysT @Int @Bool (1, True)+-- ((1,True),(True,1))+bothWaysT+  :: forall {k} (a :: k) b. (SymMonoidal k, HasBinaryProducts k, Ob a, Ob b) => a ** b ~> (a ** b) && (b ** a)+bothWaysT = toSMC @(F a :** F b) \p -> with p (split p \x y -> y ** x)++-- | Double negation introduction: a consumer of a consumer of @a@ hands it the @a@. This is+-- 'ret', written out.+dniT :: forall {k} (a :: k). (Dialogue k, Ob a) => a ~> Dual (Dual a)+dniT = toSMC @(F a) @(Up (F a)) \x -> cont (x |>)++-- | Double negation elimination, the classical direction: a computation is its value. Binding its+-- consumer with 'cont' and cutting would only give the computation back.+dneT :: forall {k} (a :: k). (StarAutonomous k, Ob a) => Dual (Dual a) ~> a+dneT = toSMC @(Up (F a)) @(F a) \nn -> classical nn++-- | Sequencing: run the input computation, and continue with @f@ on its value. In a category with+-- @'Dual' a = a ~~> r@ this is the bind of the continuation monad.+bindT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> Dual (Dual b)) -> Dual (Dual a) ~> Dual (Dual b)+bindT f = toSMC @(Up (F a)) @(Up (F b)) \m -> SMC.do+  x <- m+  lift @(F a) @(Up (F b)) f x++-- | Contraposition: a consumer of @b@ consumes @a@ through @f@.+contraT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => (a ~> b) -> Dual b ~> Dual a+contraT f = toSMC @(Not (F b)) @(Not (F a)) \nb -> cont \x -> cut nb (lift @(F a) @(F b) f x)++-- | Par is symmetric: bind both outputs and hand them to the input the other way round. This is+-- 'Proarrow.Category.Monoidal.Dialogue.parSwap'.+parSwapT :: forall {k} (a :: k) b. (Dialogue k, Ob a, Ob b) => Par a b ~> Par b a+parSwapT = toSMC @(F a :## F b) @(F b :## F a) \p -> cont \(kb, ka) -> ka ** kb |> p++-- | Linear (weak) distributivity, @a ⊗ (b ⅋ c) ⊸ (a ⊗ b) ⅋ c@: the @b@ the input emits is paired+-- with @a@ and sent to the first output, and its @c@ goes to the second. This is+-- 'Proarrow.Category.Monoidal.Dialogue.weakDistL'.+weakDistT+  :: forall {k} (a :: k) b c+   . (Dialogue k, Ob a, Ob b, Ob c)+  => a ** Par b c ~> Par (a ** b) c+weakDistT = toSMC @(F a :** (F b :## F c)) @((F a :** F b) :## F c) \(a, bc) ->+  cont \(kab, kc) -> cont (\b -> a ** b |> kab) ** kc |> bc++-- | Composition in index notation, as matrix multiplication: the entry at @i@ and @k@ is the sum over+-- @j@ of the entries of @f@ and @g@. It is @g . f@.+matMulT :: forall {k} (a :: k) b c. (SymMonoidal k, Frobenius b, Frobenius c, Ob a) => (a ~> b) -> (b ~> c) -> a ~> c+matMulT f g = toSMC @(F a) \i -> sumOver @(F c) \k -> sumOver @(F b) \j ->+  delta (lift f i) j *^ delta (lift g j) k *^ k++-- | The trace in index notation: the sum of the diagonal entries.+traceIdxT :: forall {k} (a :: k). (SymMonoidal k, Frobenius a) => (a ~> a) -> Unit ~> (Unit :: k)+traceIdxT f = toSMC @I \() -> sumOver @(F a) \i -> delta (lift f i) i++-- | The entrywise product of two morphisms: two boxes that produce the same index.+hadamardT :: forall {k} (a :: k) b. (SymMonoidal k, Frobenius a, Frobenius b) => (a ~> b) -> (a ~> b) -> a ~> b+hadamardT f g = toSMC @(F a) \i -> sumOver @(F b) \j ->+  delta (lift f i) j *^ delta (lift g i) j *^ j++-- | The snake on the dual: join the input with the first end of a new pair, and continue with the+-- second. Here the wires meet in the order they come, so no swap is needed.+snakeDualT :: forall {k} (a :: k). (CompactClosed k, Ob a) => Dual a ~> Dual a+snakeDualT = toSMC @(Not (F a)) \x -> SMC.do+  (a, a') <- produce+  () <- annihilate x a+  a'
+ src/Proarrow/Tools/SMC/Internal/Additive.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": the additives. It exports everything, also what the+-- public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Additive where++import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (Promonad (..), obj)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++-- | Both of two alternatives over the same variables: the product. This needs products.+{-# INLINE with #-}+with+  :: forall {k} (a :: SYN k) b d g1 g2+   . (HasBinaryProducts k, Thin (Union g1 g2) g1, Thin (Union g1 g2) g2)+  => Term d g1 a+  -> Term d g2 b+  -> Term d (Union g1 g2) (a :&& b)+with (MkTerm f) (MkTerm h) = MkTerm ((f . thin @(Union g1 g2) @g1) &&& (h . thin @(Union g1 g2) @g2))++-- | The first alternative of a product.+{-# INLINE exl #-}+exl+  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) -> Term d g a+exl = lift @(a :&& b) @a (withSynOb @a (withSynOb @b (fst @k @(Interp a) @(Interp b))))++-- | The second alternative of a product.+{-# INLINE exr #-}+exr+  :: forall {k} (a :: SYN k) b d g. (HasBinaryProducts k, KnownObj a, KnownObj b) => Term d g (a :&& b) -> Term d g b+exr = lift @(a :&& b) @b (withSynOb @a (withSynOb @b (snd @k @(Interp a) @(Interp b))))++-- | Use up a term into the unit of the product.+{-# INLINE absorb #-}+absorb :: forall {k} (s :: SYN k) d g. (HasTerminalObject k, KnownObj s) => Term d g s -> Term d g Top+absorb = lift @s @Top (withSynOb @s (terminate @k @(Interp s)))++-- | The left injection into a coproduct.+{-# INLINE inl #-}+inl+  :: forall {k} (a :: SYN k) b d g+   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => Term d g a -> Term d g (a :|| b)+inl = lift @a @(a :|| b) (withSynOb @a (withSynOb @b (lft @k @(Interp a) @(Interp b))))++-- | The right injection into a coproduct.+{-# INLINE inr #-}+inr+  :: forall {k} (a :: SYN k) b d g+   . (HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => Term d g b -> Term d g (a :|| b)+inr = lift @b @(a :|| b) (withSynOb @a (withSynOb @b (rgt @k @(Interp a) @(Interp b))))++-- | Case analysis on a coproduct. Each branch receives the contents of its alternative through a+-- pattern (see /Patterns/), and the variables of the term around it are shared between the+-- branches. This needs the tensor to distribute over the coproduct.+{-# INLINE caseOf #-}+caseOf+  :: forall {k} (a :: SYN k) b c d g r1 r2 t1 cont1 t2 cont2+   . ( Distributive k+     , KnownObj a+     , KnownObj b+     , Binds d r1 a c t1 cont1+     , Binds d r2 b c t2 cont2+     , Thin (Union r1 r2) r1+     , Thin (Union r1 r2) r2+     , Merge (Union r1 r2) g+     )+  => Term d g (a :|| b)+  -> (t1 -> cont1)+  -> (t2 -> cont2)+  -> Term d (Union (Union r1 r2) g) c+caseOf (MkTerm x) f h =+  withCtxOb @(Union r1 r2)+    ( withSynOb @a+        ( withSynOb @b+            ( MkTerm+                ( ( (bound @d @r1 @a @c f . (thin @(Union r1 r2) @r1 M.** obj @(Interp a)))+                      ||| (bound @d @r2 @b @c h . (thin @(Union r1 r2) @r2 M.** obj @(Interp b)))+                  )+                    . distL @k @(Interp (Mul (Union r1 r2))) @(Interp a) @(Interp b)+                    . (ctxOb @(Union r1 r2) M.** x)+                    . merge @(Union r1 r2) @g+                )+            )+        )+    )++-- | There is no term of 'Zero', so from one, together with the rest of the context, anything+-- follows.+{-# INLINE absurd #-}+absurd+  :: forall {k} (s :: SYN k) c d g1 g2+   . (Distributive k, KnownObj s, KnownObj c, Merge g1 g2)+  => Term d g1 s -> Term d g2 Zero -> Term d (Union g1 g2) c+absurd e z = lift @(s :** Zero) @c (withSynOb @s (withSynOb @c (initiate @k @(Interp c) . absorbL @k @(Interp s)))) (e ** z)
+ src/Proarrow/Tools/SMC/Internal/Closed.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": functions and traces. It exports everything, also what+-- the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Closed where++import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Strength (TracedMonoidal, trace)+import Proarrow.Core (CategoryOf (..), Promonad (..))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++infixl 8 !++-- | A function: the body receives the argument through a pattern (see /Patterns/). This needs the+-- category to be closed.+{-# INLINE lam #-}+lam+  :: forall {k} d r (a :: SYN k) b t cont+   . (Closed k, Binds d r a b t cont)+  => (t -> cont)+  -> Term d r (a :-> b)+lam k = withCtxOb @r (withSynOb @a (MkTerm (curry @k @(Interp (Mul r)) @(Interp a) (bound @d @r @a @b k))))++-- | Trace: the body receives the value fed back through a pattern (see /Patterns/), and returns+-- it again next to the result. This needs the category to be traced.+{-# INLINE loop #-}+loop+  :: forall {k} (u :: SYN k) b d r t cont+   . (TracedMonoidal k, KnownObj b, Binds d r u (b :** u) t cont)+  => (t -> cont)+  -> Term d r b+loop k =+  withCtxOb @r+    ( withSynOb @u+        (withSynOb @b (MkTerm (trace @(~>) @(Interp u) @(Interp (Mul r)) @(Interp b) (bound @d @r @u @(b :** u) k))))+    )++-- | Function application. A variable both the function and its argument use is copied.+{-# INLINE (!) #-}+(!)+  :: forall {k} d g1 g2 (a :: SYN k) b+   . (Closed k, KnownObj a, KnownObj b, Merge g1 g2)+  => Term d g1 (a :-> b) -> Term d g2 a -> Term d (Union g1 g2) b+MkTerm f ! MkTerm x =+  withSynOb @a (withSynOb @b (MkTerm (apply @k @(Interp a) @(Interp b) . (f M.** x) . merge @g1 @g2)))
+ src/Proarrow/Tools/SMC/Internal/Context.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": the contexts of terms, and the operations on them that+-- reorder, copy and discard variables. It exports everything, also what the public module keeps+-- hidden.+module Proarrow.Tools.SMC.Internal.Context where++import Data.Kind (Constraint, Type)+import GHC.TypeNats (CmpNat, Nat)+import Proarrow.Category.Monoidal+  ( Monoidal (..)+  , SymMonoidal (..)+  , associator'+  , associatorInv'+  , rightUnitorWith+  , swapInner+  )+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Object (Obj)+import Prelude (Ordering (..), type (~))++import Proarrow.Tools.SMC.Internal.Syntax++-- | A context: the variables a term uses, each with its id and type, by descending id.+type Ctx :: Type -> Type+type Ctx k = [(Nat, SYN k)]++-- | The type standing in for a context: the tensor of its variables' types, with the most+-- recently bound variable on the right. A single variable is just its type, so a variable is the+-- identity. The cost is that @Mul ('(n, a) ': g)@ only reduces once @g@ is known to be empty or+-- not, which 'ctxCase' tells.+type Mul :: forall {k}. Ctx k -> SYN k+type family Mul g where+  Mul '[] = I+  Mul '[ '(n, a)] = a+  Mul ('(n, a) ': g) = Mul g :** a++-- | A context that is known to be empty or not, all the way down.+type KnownCtx :: forall {k}. Ctx k -> Constraint+class KnownCtx (g :: Ctx k) where+  -- | Case analysis on the context, which is what lets @'Mul' ('(n, a) ': g)@ reduce.+  ctxCase :: ((g ~ '[]) => r) -> (forall n a g'. (g ~ ('(n, a) ': g'), KnownObj a, KnownCtx g') => r) -> r++  -- | The tensor of a context is an object. A method rather than a function over 'ctxCase', so that+  -- at a known context it is not recursive and can be inlined.+  withCtxOb :: (Monoidal k) => ((Ob (Interp (Mul g))) => r) -> r++instance KnownCtx ('[] :: Ctx k) where+  {-# INLINE ctxCase #-}+  {-# INLINE withCtxOb #-}+  ctxCase e _ = e+  withCtxOb r = r++instance (KnownObj a, KnownCtx g) => KnownCtx ('(n, a) ': g) where+  {-# INLINE ctxCase #-}+  {-# INLINE withCtxOb #-}+  ctxCase _ c = c+  withCtxOb r = ctxCase @g (withSynOb @a r) (withCtxOb @g (withSynOb @a (withOb2 @_ @(Interp (Mul g)) @(Interp a) r)))++-- | The identity on the tensor of a context.+{-# INLINE ctxOb #-}+ctxOb :: forall {k} (g :: Ctx k). (Monoidal k, KnownCtx g) => Obj (Interp (Mul g))+ctxOb = withCtxOb @g (obj @(Interp (Mul g)))++-- | A new variable on the right of a context: a unitor if the context was empty, and nothing+-- otherwise.+{-# INLINE snoc #-}+snoc+  :: forall {k} n (a :: SYN k) g+   . (Monoidal k, KnownObj a, KnownCtx g) => Interp (Mul g) ** Interp a ~> Interp (Mul ('(n, a) ': g))+snoc = ctxCase @g (withSynOb @a leftUnitor) (ctxOb @('(n, a) ': g))++-- | The context of two terms used side by side.+type Union :: forall {k}. Ctx k -> Ctx k -> Ctx k+type family Union g1 g2 where+  Union '[] g2 = g2+  Union g1 '[] = g1+  Union ('(n, a) ': g1) ('(m, b) ': g2) = UnionBy (CmpNat n m) ('(n, a) ': g1) ('(m, b) ': g2)++type UnionBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k+type family UnionBy o g1 g2 where+  UnionBy GT (x ': g1) g2 = x ': Union g1 g2+  UnionBy LT g1 (y ': g2) = y ': Union g1 g2+  UnionBy EQ (x ': g1) (y ': g2) = x ': Union g1 g2++-- | The newest variable split off the tensor of a context, the inverse of 'snoc'.+{-# INLINE unsnoc #-}+unsnoc+  :: forall {k} n (a :: SYN k) g+   . (Monoidal k, KnownObj a, KnownCtx g) => Interp (Mul ('(n, a) ': g)) ~> Interp (Mul g) ** Interp a+unsnoc = ctxCase @g (withSynOb @a leftUnitorInv) (ctxOb @('(n, a) ': g))++-- | Split the tensor of the union of two contexts into the tensors of the two contexts. This is+-- where the wires are reordered, the only place 'swap' is used, and where a variable that both+-- contexts have is copied.+type Merge :: forall {k}. Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => Merge (g1 :: Ctx k) g2 where+  merge :: Interp (Mul (Union g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)++instance (Monoidal k, KnownCtx g2) => Merge ('[] :: Ctx k) g2 where+  {-# INLINE merge #-}+  merge = withCtxOb @g2 leftUnitorInv++instance (Monoidal k, KnownCtx ('(n, a) ': g1)) => Merge ('(n, a) ': g1 :: Ctx k) '[] where+  {-# INLINE merge #-}+  merge = withCtxOb @('(n, a) ': g1) rightUnitorInv++instance+  ( Monoidal k+  , KnownObj a+  , KnownObj b+  , KnownCtx g1+  , KnownCtx g2+  , MergeBy (CmpNat n m) ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  )+  => Merge ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  where+  {-# INLINE merge #-}+  merge = mergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)++-- | 'merge' for two non-empty contexts, by which of the two has the larger head id.+type MergeBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => MergeBy o (g1 :: Ctx k) g2 where+  mergeBy :: Interp (Mul (UnionBy o g1 g2)) ~> Interp (Mul g1) ** Interp (Mul g2)++-- The union of two non-empty contexts is not empty, so its tensor splits off the newest variable+-- as is, which the equality says for GHC. If the newest variable is alone on its side, merging is+-- one swap or nothing.+instance+  ( SymMonoidal k+  , Merge g1 ('(m, b) ': g2)+  , KnownObj (a :: SYN k)+  , KnownObj b+  , Mul ('(n, a) ': Union g1 ('(m, b) ': g2)) ~ (Mul (Union g1 ('(m, b) ': g2)) :** a)+  )+  => MergeBy GT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE mergeBy #-}+  mergeBy =+    withCtxOb @('(m, b) ': g2)+      ( withSynOb @a+          ( ctxCase @g1+              (swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))+              ( associatorInv' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))+                  . (ctxOb @g1 M.** swap @k @(Interp (Mul ('(m, b) ': g2))) @(Interp a))+                  . associator' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)+                  . (merge @g1 @('(m, b) ': g2) M.** synOb @a)+              )+          )+      )++instance+  ( Monoidal k+  , Merge ('(n, a) ': g1) g2+  , KnownObj a+  , KnownObj (b :: SYN k)+  , Mul ('(m, b) ': Union ('(n, a) ': g1) g2) ~ (Mul (Union ('(n, a) ': g1) g2) :** b)+  )+  => MergeBy LT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE mergeBy #-}+  mergeBy =+    ctxCase @g2+      (ctxOb @('(m, b) ': '(n, a) ': g1))+      ( associator' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)+          . (merge @('(n, a) ': g1) @g2 M.** synOb @b)+      )++-- | A variable both contexts have is copied, one copy for each side.+instance+  ( SymMonoidal k+  , CocommutativeComonoid (Interp a)+  , KnownObj (a :: SYN k)+  , a ~ b+  , Merge g1 g2+  , KnownCtx (Union g1 g2)+  )+  => MergeBy EQ ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE mergeBy #-}+  mergeBy = ctxCase @g1 (ctxCase @g2 (comult @(Interp a)) withRest) withRest+    where+      -- When the variable is all both sides have, this is just the copy.+      withRest :: Interp (Mul ('(n, a) ': Union g1 g2)) ~> Interp (Mul ('(n, a) ': g1)) ** Interp (Mul ('(m, b) ': g2))+      withRest =+        withCtxOb @g1+          ( withCtxOb @g2+              ( withSynOb @a+                  ( (snoc @n @a @g1 M.** snoc @m @a @g2)+                      . swapInner @(Interp (Mul g1)) @(Interp (Mul g2)) @(Interp a) @(Interp a)+                      . (merge @g1 @g2 M.** comult @(Interp a))+                      . unsnoc @n @a @(Union g1 g2)+                  )+              )+          )++-- | The inverse of 'merge' for two contexts without a variable in common, which a @rec@ block+-- uses to put the wires it feeds back together with the others.+type Unmerge :: forall {k}. Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => Unmerge (g1 :: Ctx k) g2 where+  unmerge :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (Union g1 g2))++instance (Monoidal k, KnownCtx g2) => Unmerge ('[] :: Ctx k) g2 where+  {-# INLINE unmerge #-}+  unmerge = withCtxOb @g2 leftUnitor++instance (Monoidal k, KnownCtx ('(n, a) ': g1)) => Unmerge ('(n, a) ': g1 :: Ctx k) '[] where+  {-# INLINE unmerge #-}+  unmerge = withCtxOb @('(n, a) ': g1) rightUnitor++instance+  ( Monoidal k+  , KnownObj a+  , KnownObj b+  , KnownCtx g1+  , KnownCtx g2+  , UnmergeBy (CmpNat n m) ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  )+  => Unmerge ('(n, a) ': g1 :: Ctx k) ('(m, b) ': g2)+  where+  {-# INLINE unmerge #-}+  unmerge = unmergeBy @(CmpNat n m) @('(n, a) ': g1) @('(m, b) ': g2)++-- | 'unmerge' for two non-empty contexts, by which of the two has the larger head id.+type UnmergeBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Constraint+class (KnownCtx g1, KnownCtx g2) => UnmergeBy o (g1 :: Ctx k) g2 where+  unmergeBy :: Interp (Mul g1) ** Interp (Mul g2) ~> Interp (Mul (UnionBy o g1 g2))++instance+  ( SymMonoidal k+  , Unmerge g1 ('(m, b) ': g2)+  , KnownObj (a :: SYN k)+  , KnownObj b+  , Mul ('(n, a) ': Union g1 ('(m, b) ': g2)) ~ (Mul (Union g1 ('(m, b) ': g2)) :** a)+  )+  => UnmergeBy GT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE unmergeBy #-}+  unmergeBy =+    withCtxOb @('(m, b) ': g2)+      ( withSynOb @a+          ( ctxCase @g1+              (swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))+              ( (unmerge @g1 @('(m, b) ': g2) M.** synOb @a)+                  . associatorInv' (ctxOb @g1) (ctxOb @('(m, b) ': g2)) (synOb @a)+                  . (ctxOb @g1 M.** swap @k @(Interp a) @(Interp (Mul ('(m, b) ': g2))))+                  . associator' (ctxOb @g1) (synOb @a) (ctxOb @('(m, b) ': g2))+              )+          )+      )++instance+  ( Monoidal k+  , Unmerge ('(n, a) ': g1) g2+  , KnownObj a+  , KnownObj (b :: SYN k)+  , Mul ('(m, b) ': Union ('(n, a) ': g1) g2) ~ (Mul (Union ('(n, a) ': g1) g2) :** b)+  )+  => UnmergeBy LT ('(n, a) ': g1) ('(m, b) ': g2)+  where+  {-# INLINE unmergeBy #-}+  unmergeBy =+    ctxCase @g2+      (ctxOb @('(m, b) ': '(n, a) ': g1))+      ( (unmerge @('(n, a) ': g1) @g2 M.** synOb @b)+          . associatorInv' (ctxOb @('(n, a) ': g1)) (ctxOb @g2) (synOb @b)+      )++-- | Keep the variables of @g@ that @h@ has and discard the others, for an alternative of the+-- additives that does not use all the variables of the other. Every variable of @h@ must be in+-- @g@.+type Thin :: forall {k}. Ctx k -> Ctx k -> Constraint+class (KnownCtx g, KnownCtx h) => Thin (g :: Ctx k) h where+  thin :: Interp (Mul g) ~> Interp (Mul h)++instance (Monoidal k) => Thin ('[] :: Ctx k) '[] where+  {-# INLINE thin #-}+  thin = obj @(Unit :: k)++instance (Monoidal k, Comonoid (Interp a), KnownObj (a :: SYN k), Thin g '[]) => Thin ('(n, a) ': g) '[] where+  {-# INLINE thin #-}+  thin = leftUnitor @k @Unit . (thin @g @'[] M.** counit @(Interp a)) . unsnoc @n @a @g++instance+  (KnownObj a, KnownObj b, KnownCtx g, KnownCtx h, ThinBy (CmpNat n m) ('(n, a) ': g) ('(m, b) ': h))+  => Thin ('(n, a) ': g :: Ctx k) ('(m, b) ': h)+  where+  {-# INLINE thin #-}+  thin = thinBy @(CmpNat n m) @('(n, a) ': g) @('(m, b) ': h)++-- | 'thin' for two non-empty contexts, by which of the two has the larger head id.+type ThinBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Constraint+class (KnownCtx g, KnownCtx h) => ThinBy o (g :: Ctx k) h where+  thinBy :: Interp (Mul g) ~> Interp (Mul h)++instance (Monoidal k, KnownObj (a :: SYN k), a ~ b, Thin g h) => ThinBy EQ ('(n, a) ': g) ('(m, b) ': h) where+  {-# INLINE thinBy #-}+  thinBy = withSynOb @a (snoc @m @a @h . (thin @g @h M.** synOb @a) . unsnoc @n @a @g)++instance+  (Monoidal k, Comonoid (Interp a), KnownObj (a :: SYN k), KnownObj b, Thin g ('(m, b) ': h))+  => ThinBy GT ('(n, a) ': g) ('(m, b) ': h)+  where+  {-# INLINE thinBy #-}+  thinBy =+    withCtxOb @('(m, b) ': h)+      (rightUnitor . (thin @g @('(m, b) ': h) M.** counit @(Interp a)) . unsnoc @n @a @g)++-- | A binder's variable @n@ on the right of @r@, what the body uses besides it, given the body's+-- context @g@: 'snoc' if the body uses the variable, and its counit otherwise. The binder's+-- variable is the newest in scope, so it can only be at the head of @g@. The functional+-- dependency, rather than a type family, gives @r@, so that a binder costs one comparison of ids.+type BindVar :: forall {k}. Nat -> SYN k -> Ctx k -> Ctx k -> Constraint+class (KnownCtx r) => BindVar n (a :: SYN k) g r | n g -> r where+  bindVar :: Interp (Mul r) ** Interp a ~> Interp (Mul g)++instance (Monoidal k, Comonoid (Interp a), KnownObj (a :: SYN k)) => BindVar n a '[] '[] where+  {-# INLINE bindVar #-}+  bindVar = rightUnitorWith @Unit (counit @(Interp a))++instance (KnownCtx r, BindVarBy (CmpNat n m) n a ('(m, b) ': g) r) => BindVar n (a :: SYN k) ('(m, b) ': g) r where+  {-# INLINE bindVar #-}+  bindVar = bindVarBy @(CmpNat n m) @n @a @('(m, b) ': g) @r++-- | 'bindVar' for a non-empty context, by whether its head is the new variable.+type BindVarBy :: forall {k}. Ordering -> Nat -> SYN k -> Ctx k -> Ctx k -> Constraint+class BindVarBy o n (a :: SYN k) g r | o n g -> r where+  bindVarBy :: Interp (Mul r) ** Interp a ~> Interp (Mul g)++instance (Monoidal k, KnownObj (a :: SYN k), a ~ b, KnownCtx g) => BindVarBy EQ n a ('(m, b) ': g) g where+  {-# INLINE bindVarBy #-}+  bindVarBy = snoc @m @a @g++instance+  (Monoidal k, Comonoid (Interp a), KnownObj (a :: SYN k), KnownObj b, KnownCtx g)+  => BindVarBy GT n a ('(m, b) ': g) ('(m, b) ': g)+  where+  {-# INLINE bindVarBy #-}+  bindVarBy =+    withCtxOb @('(m, b) ': g)+      (rightUnitorWith @(Interp (Mul ('(m, b) ': g))) (counit @(Interp a)))++type HeadId :: forall {k}. Ctx k -> Nat+type family HeadId g where+  HeadId ('(n, a) ': g) = n++-- | The variables of @g@ whose ids are not in @h@.+type Minus :: forall {k}. Ctx k -> Ctx k -> Ctx k+type family Minus g h where+  Minus '[] h = '[]+  Minus g '[] = g+  Minus ('(n, a) ': g) ('(m, b) ': h) = MinusBy (CmpNat n m) ('(n, a) ': g) ('(m, b) ': h)++type MinusBy :: forall {k}. Ordering -> Ctx k -> Ctx k -> Ctx k+type family MinusBy o g h where+  MinusBy GT (x ': g) h = x ': Minus g h+  MinusBy EQ (x ': g) (y ': h) = Minus g h+  MinusBy LT g (y ': h) = Minus g h++-- | The variables of @g@ whose ids are in @h@.+type Inter :: forall {k}. Ctx k -> Ctx k -> Ctx k+type Inter g h = Minus g (Minus g h)
+ src/Proarrow/Tools/SMC/Internal/Dialogue.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": inputs and outputs in dialogue categories, and duals.+-- It exports everything, also what the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Dialogue where++import Data.Kind (Type)+import GHC.TypeNats (Nat)+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), dualityCounitSA)+import Proarrow.Category.Monoidal.IsoMix (IsoMix (..))+import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomous (..))+import Proarrow.Core (Promonad (..))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++infixl 1 |>+infixl 7 :##++-- | A new pair of wires, a variable and its dual, from nothing: the unit of the duality. This+-- needs the category to be compact closed.+{-# INLINE produce #-}+produce :: forall {k} (a :: SYN k) d. (CompactClosed k, KnownObj a) => Term d '[] (a :** Not a)+produce = withSynOb @a (MkTerm (dualityUnit @k @(Interp a)))++-- | Join a dual and its wire into nothing: the counit of the duality, which an isomix category+-- has.+{-# INLINE annihilate #-}+annihilate+  :: forall {k} (a :: SYN k) d g1 g2+   . (IsoMix k, KnownObj a, Merge g1 g2)+  => Consumer d g1 a -> Term d g2 a -> Term d (Union g1 g2) I+annihilate x y = lift @(Not a :** a) @I (withSynOb @a (dualityCounit @k @(Interp a))) (x ** y)++-- | A consumer of @a@: a term of its negation.+type Consumer :: forall {k}. Nat -> Ctx k -> SYN k -> Type+type Consumer d g a = Term d g (Not a)++-- | A producer and a consumer meeting: a term of the unit of par.+type Command :: forall {k}. Nat -> Ctx k -> Type+type Command d g = Term d g (Not I)++-- | Par, the negation of the tensor of the negations, interpreted as 'Proarrow.Category.Monoidal.Dialogue.Par'.+type (:##) :: forall {k}. SYN k -> SYN k -> SYN k+type a :## b = Not (Not a :** Not b)++-- | A consumer meets a producer: @cut k t@ gives @t@ to @k@, like applying a continuation.+{-# INLINE cut #-}+cut+  :: forall {k} (a :: SYN k) d g1 g2+   . (Dialogue k, KnownObj a, Merge g1 g2)+  => Consumer d g1 a -> Term d g2 a -> Command d (Union g1 g2)+cut x y = lift @(Not a :** a) @(Not I) (withSynOb @a (dualityCounitSA @(Interp a))) (x ** y)++-- | 'cut' with the producer first, as System L writes @⟨t | k⟩@: @t |> k@ sends @t@ into @k@.+{-# INLINE (|>) #-}+(|>)+  :: forall {k} (a :: SYN k) d g1 g2+   . (Dialogue k, KnownObj a, Merge g2 g1)+  => Term d g1 a -> Consumer d g2 a -> Command d (Union g2 g1)+t |> k = cut k t++-- | The binder of System L. @cont \\x -> c@ is a term of @'Not' a@: it receives an @a@ through the+-- pattern @x@ (see /Patterns/) and runs the command @c@ with it.+--+-- What that @a@ is depends on how the result is used. As a 'Consumer' of @a@, the @a@ is an input+-- and @cont@ is μ̃: the seller in a shop receives the order, @cont \\(name, card, replyTo) -> …@. As+-- a term of the negative type @'Not' a@ in its own right, the @a@ is the consumer of an output and+-- @cont@ is μ, Haskell's @callCC@: a computation @'Up' b@ receives the consumer of its result,+-- @cont \\k -> … |> k@; a par @b ':##' c@ receives a consumer for each side, @cont \\(kb, kc) -> …@;+-- and a command, @'Not' 'I'@, receives nothing, @cont \\() -> …@. A consumer of a par is a+-- computation, which a nested pair pattern runs to get at the consumers of its sides.+{-# INLINE cont #-}+cont+  :: forall {k} d r (a :: SYN k) t cont+   . (Dialogue k, Binds d r a (Not I) t cont)+  => (t -> cont)+  -> Term d r (Not a)+cont k =+  withCtxOb @r+    ( withSynOb @a+        ( MkTerm+            ( dual (rightUnitorInv @k @(Interp a))+                . linDist @k @(Interp (Mul r)) @(Interp a) @Unit (bound @d @r @a @(Not I) k)+            )+        )+    )++-- | Store a term of a negative type as a value: the same morphism at the positive type @'Dn' n@,+-- which a bind names instead of running. This is call by push value's @thunk@, 'recast' to 'Dn'.+{-# INLINE thunk #-}+thunk :: forall {k} (n :: SYN k) d g. Term d g n -> Term d g (Dn n)+thunk = recast++-- | A stored term at its negative type again, where a bind runs it. This is call by push value's+-- @force@, 'recast' from 'Dn'.+{-# INLINE force #-}+force :: forall {k} (n :: SYN k) d g. Term d g (Dn n) -> Term d g n+force = recast++-- | A computation as its value again: double negation elimination, which only a *-autonomous+-- category has. There every type is equivalent to its shift, so the polarities collapse.+{-# INLINE classical #-}+classical :: forall {k} (a :: SYN k) d g. (StarAutonomous k, KnownObj a) => Term d g (Up a) -> Term d g a+classical = withSynOb @a (lift @(Up a) @a (doubleNeg @k @(Interp a)))
+ src/Proarrow/Tools/SMC/Internal/Do.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": @do@ notation, including @rec@ blocks. It exports+-- everything, also what the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Do where++import Data.Kind (Constraint, Type)+import GHC.TypeNats (Nat, type (+))+import Proarrow.Category.Monoidal (Monoidal, Tensor)+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Dialogue (Dialogue)+import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal)+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Prelude (type (~))+import Prelude qualified as P++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++-- Do notation++-- | A bind in a @do@ block: a term taken apart by a pattern, or the variables of a @rec@ block.+type Bind :: Type -> Type -> Type -> Type -> Type -> Constraint+class Bind k m t cont r | m -> k where+  -- | Bind the right hand side to the pattern of the continuation.+  (>>=) :: m -> (t -> cont) -> r++-- | A term on the right hand side is taken apart by the pattern. Incoherent, so that it is chosen+-- as soon as the right hand side is known, unless the right hand side is a computation.+instance {-# INCOHERENT #-} (BindTerm k t (Term d g a) cont r) => Bind k (Term d g (a :: SYN k)) t cont r where+  {-# INLINE (>>=) #-}+  (>>=) = bindTerm @k @t++-- | A bind of a term, by its pattern. A variable pattern binds a new variable, so that the right+-- hand side is computed once however often the variable is used. The other patterns take the+-- right hand side apart into new variables already.+type BindTerm :: Type -> Type -> Type -> Type -> Type -> Constraint+class BindTerm k t m cont r where+  bindTerm :: m -> (t -> cont) -> r++-- The instances are incoherent, as for patterns: a variable pattern's type is often still unknown+-- when the instance is chosen.++instance+  {-# INCOHERENT #-}+  (Monoidal k, Binds d r a b t cont, Merge r g, r' ~ Term d (Union r g) b)+  => BindTerm k t (Term d g (a :: SYN k)) cont r'+  where+  {-# INLINE bindTerm #-}+  bindTerm (MkTerm m) k = withCtxOb @r (MkTerm (bound @d @r @a @b k . (ctxOb @r M.** m) . merge @r @g))++instance {-# INCOHERENT #-} (BindPat k (Term d g a) (x, y) cont r) => BindTerm k (x, y) (Term d g (a :: SYN k)) cont r where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++instance+  {-# INCOHERENT #-}+  (BindPat k (Term d g a) (x, y, z) cont r)+  => BindTerm k (x, y, z) (Term d g (a :: SYN k)) cont r+  where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++instance+  {-# INCOHERENT #-}+  (BindPat k (Term d g a) (w, x, y, z) cont r)+  => BindTerm k (w, x, y, z) (Term d g (a :: SYN k)) cont r+  where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++instance {-# INCOHERENT #-} (BindPat k (Term d g a) () cont r) => BindTerm k () (Term d g (a :: SYN k)) cont r where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++-- | A computation on the right hand side runs first, and the rest of the block is negative.+instance+  ( Dialogue k+  , KnownObj y+  , Merge g r+  , TyOf @k cont ~ Not y+  , Binds d r a (Not y) t cont+  , r' ~ Term d (Union g r) (Not y)+  )+  => Bind k (Term d g (Not (Not a))) t cont r'+  where+  {-# INLINE (>>=) #-}+  m >>= k = runUp @d @g @r @a @y m (bound @d @r @a @(Not y) k)++-- | The statement of a @rec@ block, whose continuation is its 'return'.+instance+  (Bind k (Term d g a) t cont r', r ~ Ret tt r')+  => Bind k (Term d g (a :: SYN k)) t (Ret tt cont) r+  where+  {-# INLINE (>>=) #-}+  x >>= k = Ret (x >>= \p -> unRet (k p))++-- | The body of a @rec@ block, tagged with the tuple of its variables. GHC's translation passes+-- that tuple to both 'return' and 'mfix', and this tag is what makes them the same.+type Ret :: Type -> Type -> Type+newtype Ret t x = Ret x++unRet :: Ret t x -> x+unRet (Ret x) = x++-- | The variables of a @rec@ block, as GHC tuples them up.+type RecVars :: Type -> Type -> Constraint+class RecVars k t | t -> k where+  type Vars k t :: Ctx k+  recVars :: t++instance (Monoidal k, KnownObj (a :: SYN k)) => RecVars k (Term d '[ '(n, a)] a) where+  {-# INLINE recVars #-}+  type Vars k (Term d '[ '(n, a)] a) = '[ '(n, a)]+  recVars = var @n @a++instance (RecVars k x, RecVars k y) => RecVars k (x, y) where+  {-# INLINE recVars #-}+  type Vars k (x, y) = Union (Vars k x) (Vars k y)+  recVars = (recVars, recVars)++instance (RecVars k x, RecVars k y, RecVars k z) => RecVars k (x, y, z) where+  {-# INLINE recVars #-}+  type Vars k (x, y, z) = Union (Vars k x) (Vars k (y, z))+  recVars = (recVars, recVars, recVars)++instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w) => RecVars k (x, y, z, w) where+  {-# INLINE recVars #-}+  type Vars k (x, y, z, w) = Union (Vars k x) (Vars k (y, z, w))+  recVars = (recVars, recVars, recVars, recVars)++instance (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v) => RecVars k (x, y, z, w, v) where+  {-# INLINE recVars #-}+  type Vars k (x, y, z, w, v) = Union (Vars k x) (Vars k (y, z, w, v))+  recVars = (recVars, recVars, recVars, recVars, recVars)++instance+  (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v, RecVars k u)+  => RecVars k (x, y, z, w, v, u)+  where+  {-# INLINE recVars #-}+  type Vars k (x, y, z, w, v, u) = Union (Vars k x) (Vars k (y, z, w, v, u))+  recVars = (recVars, recVars, recVars, recVars, recVars, recVars)++-- | The variables of a @rec@ block again, at a depth of their own: the rest of the block uses them+-- deeper than the block did. It is asked for both ways, so that what is known about the variables+-- on either side of the block determines the other.+type AnyDepth :: Type -> Type -> Constraint+class AnyDepth t t'++instance (t' ~ Term d' g a) => AnyDepth (Term d g a) t'++instance (AnyDepth x x', AnyDepth y y', t' ~ (x', y')) => AnyDepth (x, y) t'++instance (AnyDepth x x', AnyDepth y y', AnyDepth z z', t' ~ (x', y', z')) => AnyDepth (x, y, z) t'++instance (AnyDepth x x', AnyDepth y y', AnyDepth z z', AnyDepth w w', t' ~ (x', y', z', w')) => AnyDepth (x, y, z, w) t'++instance+  (AnyDepth x x', AnyDepth y y', AnyDepth z z', AnyDepth w w', AnyDepth v v', t' ~ (x', y', z', w', v'))+  => AnyDepth (x, y, z, w, v) t'++instance+  ( AnyDepth x x'+  , AnyDepth y y'+  , AnyDepth z z'+  , AnyDepth w w'+  , AnyDepth v v'+  , AnyDepth u u'+  , t' ~ (x', y', z', w', v', u')+  )+  => AnyDepth (x, y, z, w, v, u) t'++-- | The end of a @rec@ block: all its variables, as the tensor of their context.+{-# INLINE return #-}+return+  :: forall k t d. (Monoidal k, RecVars k t, KnownCtx (Vars k t)) => t -> Ret t (Term d (Vars k t) (Mul (Vars k t)))+return _ = Ret (MkTerm (ctxOb @(Vars k t)))++-- | A @rec@ block before tracing: its body, from its context @g@ to all its variables. Which of them+-- are fed back and which are passed on is only known with the rest of the block, see the 'Bind'+-- instance.+type Rec :: forall {k}. Nat -> Type -> Ctx k -> Type+data Rec d t g where+  Rec :: forall {k} d t (g :: Ctx k). (Interp (Mul g) ~> Interp (Mul (Vars k t))) -> Rec d t g++-- | The body of a @rec@ block, to be traced by the bind after it.+{-# INLINE mfix #-}+mfix :: forall {k} t d (g :: Ctx k). (RecVars k t) => (t -> Ret t (Term d g (Mul (Vars k t)))) -> Rec d t g+mfix f = case unRet (f recVars) of MkTerm body -> Rec body++-- | The rest of the @do@ block after a @rec@ block, which traces it. The variables of the block+-- that the block itself uses are fed back, the ones the rest uses are passed on, a variable that+-- both use is copied, and one that neither uses is discarded. The rest gets the variables anew,+-- with the same ids, so that it can use them at its own depth.+instance+  ( TracedMonoidal k+  , RecVars k t+  , AnyDepth t t'+  , AnyDepth t' t+  , RecVars k t'+  , cont ~ Term (HeadId (Vars k t) + 1) (CtxOf @k cont) (TyOf @k cont)+  , r ~ Term d (Union (Minus (CtxOf @k cont) (Vars k t)) (Minus g (Vars k t))) (TyOf @k cont)+  , Unmerge (Inter g (Vars k t)) (Minus g (Vars k t))+  , Union (Inter g (Vars k t)) (Minus g (Vars k t)) ~ g+  , Thin (Vars k t) (Union (Inter g (Vars k t)) (Inter (CtxOf @k cont) (Vars k t)))+  , Merge (Inter g (Vars k t)) (Inter (CtxOf @k cont) (Vars k t))+  , Merge (Minus (CtxOf @k cont) (Vars k t)) (Minus g (Vars k t))+  , Unmerge (Minus (CtxOf @k cont) (Vars k t)) (Inter (CtxOf @k cont) (Vars k t))+  , Union (Minus (CtxOf @k cont) (Vars k t)) (Inter (CtxOf @k cont) (Vars k t)) ~ CtxOf @k cont+  )+  => Bind k (Rec d t (g :: Ctx k)) t' cont r+  where+  {-# INLINE (>>=) #-}+  Rec body >>= k = case k (recVars @k @t') of+    MkTerm rest ->+      withCtxOb @(Minus (CtxOf @k cont) (Vars k t))+        ( withCtxOb @(Inter g (Vars k t))+            ( withCtxOb @(Minus g (Vars k t))+                ( withCtxOb @(Inter (CtxOf @k cont) (Vars k t))+                    ( MkTerm+                        ( rest+                            . unmerge @(Minus (CtxOf @k cont) (Vars k t)) @(Inter (CtxOf @k cont) (Vars k t))+                            . ( ctxOb @(Minus (CtxOf @k cont) (Vars k t))+                                  M.** coact+                                    @Tensor+                                    @(~>)+                                    @(Interp (Mul (Inter g (Vars k t))))+                                    @(Interp (Mul (Minus g (Vars k t))))+                                    @(Interp (Mul (Inter (CtxOf @k cont) (Vars k t))))+                                    ( merge @(Inter g (Vars k t)) @(Inter (CtxOf @k cont) (Vars k t))+                                        . thin @(Vars k t) @(Union (Inter g (Vars k t)) (Inter (CtxOf @k cont) (Vars k t)))+                                        . body+                                        . unmerge @(Inter g (Vars k t)) @(Minus g (Vars k t))+                                    )+                              )+                            . merge @(Minus (CtxOf @k cont) (Vars k t)) @(Minus g (Vars k t))+                        )+                    )+                )+            )+        )++-- | GHC's translation of @rec@ refers to @fail@, but pairs of variables always match.+fail :: a+fail = P.error "Proarrow.Tools.SMC.fail: a pattern did not match"
+ src/Proarrow/Tools/SMC/Internal/Frobenius.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": index notation for categories whose index types are+-- Frobenius algebras. It exports everything, also what the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Frobenius where++import GHC.TypeNats (type (+))++import Proarrow.Category.Monoidal (Monoidal (..), rightUnitorInvWith)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, cap)+import Proarrow.Core (Promonad (..))+import Proarrow.Monoid (Monoid (..))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Pattern+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++infixl 7 *^+infixl 7 ^*++-- | An index summed over: the binder's variable is fed by the unit of its type's monoid, which,+-- copied to every use, is the sum over all the values the index can take. The body receives the+-- index through a pattern (see /Patterns/).+{-# INLINE sumOver #-}+sumOver+  :: forall {k} (a :: SYN k) d r b t cont+   . (Monoidal k, Frobenius (Interp a), Binds d r a b t cont)+  => (t -> cont)+  -> Term d r b+sumOver k =+  withCtxOb @r+    ( withSynOb @a+        ( MkTerm+            (bound @d @r @a @b k . rightUnitorInvWith @(Interp (Mul r)) (mempty @(Interp a)))+        )+    )++-- | An index summed over, as 'sumOver', for a body that refers to the index as the variable of id+-- @d@ instead of through a pattern.+{-# INLINE sumVar #-}+sumVar+  :: forall {k} (a :: SYN k) d g' g b+   . (Monoidal k, Frobenius (Interp a), KnownObj a, BindVar d a g' g)+  => Term (d + 1) g' b+  -> Term d g b+sumVar (MkTerm body) =+  withCtxOb @g+    ( withSynOb @a+        (MkTerm (body . bindVar @d @a @g' @g . rightUnitorInvWith @(Interp (Mul g)) (mempty @(Interp a))))+    )++-- | The Kronecker delta: the scalar that says two wires of an index type carry the same value. It+-- is the cap of the Frobenius algebra, @'Proarrow.Monoid.counit' . 'Proarrow.Monoid.mappend'@.+{-# INLINE delta #-}+delta+  :: forall {k} (a :: SYN k) d g1 g2+   . (Frobenius (Interp a), KnownObj a, Merge g1 g2)+  => Term d g1 a -> Term d g2 a -> Term d (Union g1 g2) I+delta x y = lift @(a :** a) @I (cap @(Interp a)) (x ** y)++-- | A term multiplied by a scalar on its left. At 'I' it is the product of two scalars.+{-# INLINE (*^) #-}+(*^)+  :: forall {k} d g1 g2 (a :: SYN k)+   . (Monoidal k, KnownObj a, Merge g1 g2)+  => Term d g1 I -> Term d g2 a -> Term d (Union g1 g2) a+s *^ x = lift @(I :** a) @a (withSynOb @a (leftUnitor @k @(Interp a))) (s ** x)++-- | A term multiplied by a scalar on its right.+{-# INLINE (^*) #-}+(^*)+  :: forall {k} d g1 g2 (a :: SYN k)+   . (Monoidal k, KnownObj a, Merge g1 g2)+  => Term d g1 a -> Term d g2 I -> Term d (Union g1 g2) a+x ^* s = lift @(a :** I) @a (withSynOb @a (rightUnitor @k @(Interp a))) (x ** s)
+ src/Proarrow/Tools/SMC/Internal/Pattern.hs view
@@ -0,0 +1,265 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": patterns and binders. It exports everything, also what+-- the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Pattern where++import Data.Kind (Constraint, Type)+import GHC.TypeNats (Nat, type (+))+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), bindDual)+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Prelude (type (~))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Syntax+import Proarrow.Tools.SMC.Internal.Term++-- | Compile a function on terms to a morphism. The function receives the input through a pattern+-- (see /Patterns/), so @()@ compiles a term without inputs and a tuple takes a tensor apart.+{-# INLINE toSMC #-}+toSMC+  :: forall {k} (a :: SYN k) b t cont+   . (Monoidal k, Binds 0 '[] a b t cont)+  => (t -> cont)+  -> Interp a ~> Interp b+toSMC k = withSynOb @a (bound @0 @'[] @a @b k . leftUnitorInv @k @(Interp a))++-- | The shift of a positive type to a negative one: a computation that produces an @a@. A term of+-- it is a consumer of consumers of @a@, so in a category with @'Dual' a = a ~~> r@ it is the+-- continuation passing type @(a -> r) -> r@.+type Up :: forall {k}. SYN k -> SYN k+type Up a = Not (Not a)++-- | Run a computation against the rest of a block. The body is what the rest does with the value,+-- given the context @r@; it becomes a consumer of the computation, whose context @g@ joins. What+-- the binds of a computation share, the counterpart of 'bound'.+{-# INLINE runUp #-}+runUp+  :: forall {k} d g r (a :: SYN k) y+   . (Dialogue k, KnownObj a, KnownObj y, Merge g r)+  => Term d g (Up a)+  -> (Interp (Mul r) ** Interp a ~> Interp (Not y))+  -> Term d (Union g r) (Not y)+runUp (MkTerm m) body =+  withCtxOb @r+    ( withSynOb @a+        ( withSynOb @y+            ( MkTerm+                ( bindDual @(Interp (Mul r)) @(Interp a) @(Interp y) body+                    . (m M.** obj @(Interp (Mul r)))+                    . merge @g @r+                )+            )+        )+    )++-- | A value as the computation that produces it: double negation introduction, and the return of+-- a @do@ block in the continuation reading. It also reads as a producer of @a@ handed over as a+-- consumer of @'Not' a@. The value can be given as a 'Tuple' of terms, built by the type expected.+{-# INLINE ret #-}+ret+  :: forall {k} (a :: SYN k) t+   . (Dialogue k, KnownObj a, Tuple k t a)+  => t -> Term (TupleDepth t) (TupleCtx k t) (Up a)+ret t = withSynOb @a (lift @a @(Up a) (doubleNegInv @k @(Interp a))) (tuple @k @t @a t)++-- | A term built from a tuple of terms, by the type it is expected to have: a term is itself, a+-- pair at a tensor is the tensor of its parts, and a pair at a computation @'Up' a@ is the+-- computation of the pair at @a@. A triple or quadruple stands for pairs nested to the left, as in+-- patterns. The parts must be at the same depth, and their contexts are merged.+type Tuple :: forall k -> Type -> SYN k -> Constraint+class Tuple k t a where+  tuple :: t -> Term (TupleDepth t) (TupleCtx k t) a++-- | The context of a tuple of terms: the union of the contexts of its parts.+type TupleCtx :: forall k -> Type -> Ctx k+type family TupleCtx k t where+  TupleCtx k (x, y) = Union (TupleCtx k x) (TupleCtx k y)+  TupleCtx k (x, y, z) = TupleCtx k ((x, y), z)+  TupleCtx k (w, x, y, z) = TupleCtx k (((w, x), y), z)+  TupleCtx k t = CtxOf @k t++-- | The depth of a tuple of terms: that of its first part.+type TupleDepth :: Type -> Nat+type family TupleDepth t where+  TupleDepth (x, y) = TupleDepth x+  TupleDepth (x, y, z) = TupleDepth x+  TupleDepth (w, x, y, z) = TupleDepth w+  TupleDepth t = DepthOf t++-- The generic instances are incoherent, as for patterns: a term's type is often still unknown when+-- the instance is chosen, and a pair defaults to a tensor until its type is known to be an 'Up'.++-- | A term is itself.+instance {-# INCOHERENT #-} (t ~ Term d g a) => Tuple k t a where+  {-# INLINE tuple #-}+  tuple t = t++-- | A pair at a tensor is the tensor of its parts.+instance+  {-# INCOHERENT #-}+  ( Monoidal k+  , a ~ (a1 :** a2)+  , Tuple k x a1+  , Tuple k y a2+  , TupleDepth y ~ TupleDepth x+  , Merge (TupleCtx k x) (TupleCtx k y)+  )+  => Tuple k (x, y) (a :: SYN k)+  where+  {-# INLINE tuple #-}+  tuple (x, y) = tuple @k @x @a1 x ** tuple @k @y @a2 y++-- | A pair at a computation is the computation of the pair at the value.+instance (Dialogue k, KnownObj a, Tuple k (x, y) a) => Tuple k (x, y) (Not (Not a) :: SYN k) where+  {-# INLINE tuple #-}+  tuple p = ret @a p++instance (Tuple k ((x, y), z) a) => Tuple k (x, y, z) a where+  {-# INLINE tuple #-}+  tuple (x, y, z) = tuple @k @((x, y), z) @a ((x, y), z)++instance (Tuple k (((w, x), y), z) a) => Tuple k (w, x, y, z) a where+  {-# INLINE tuple #-}+  tuple (w, x, y, z) = tuple @k @(((w, x), y), z) @a (((w, x), y), z)++-- | The pattern @t@ of a binder: it takes apart the variable @(n, a)@, and the binder's body+-- @cont@ then gives a term at depth @n + 1@ with type @b@, whose context is @g@ and possibly that+-- variable. Both the variable's type and the rest of the context must be known.+type Binds :: forall {k}. Nat -> Ctx k -> SYN k -> SYN k -> Type -> Type -> Constraint+class (KnownObj a, KnownCtx g) => Binds n g (a :: SYN k) b t cont where+  -- | The body of a binder, with the pattern taking apart its new variable, as a morphism from the+  -- context around it and the variable. This is what 'toSMC', 'Proarrow.Tools.SMC.lam',+  -- 'Proarrow.Tools.SMC.loop', 'Proarrow.Tools.SMC.cont', 'Proarrow.Tools.SMC.caseOf',+  -- 'Proarrow.Tools.SMC.sumOver' and the binds of @do@ notation share.+  bound :: (t -> cont) -> Interp (Mul g) ** Interp a ~> Interp b++-- The context of the body is @g'@, which only the instance needs to name.+instance+  ( KnownObj a+  , KnownCtx g+  , BindPat k (Term (n + 1) '[ '(n, a)] a) t cont (Term (n + 1) g' b)+  , BindVar n a g' g+  )+  => Binds n g (a :: SYN k) b t cont+  where+  {-# INLINE bound #-}+  bound k = case bindPat @k @(Term (n + 1) '[ '(n, a)] a) @t @cont @(Term (n + 1) g' b) (var @n @a @(n + 1)) k of+    MkTerm body -> body . bindVar @n @a @g' @g++-- | A term on the right hand side taken apart by the pattern of the continuation. The types of the+-- continuation and the result are matched with equalities, so that the instance is chosen as soon+-- as the right hand side is known.+type BindPat :: Type -> Type -> Type -> Type -> Type -> Constraint+class BindPat k m t cont r | m -> k where+  bindPat :: m -> (t -> cont) -> r++instance+  ( cont ~ Term (d + PSize t) (CtxOf @k cont) (TyOf @k cont)+  , r ~ Term d gr (TyOf @k cont)+  , Pat k t d g a (CtxOf @k cont) (TyOf @k cont) gr+  )+  => BindPat k (Term d g (a :: SYN k)) t cont r+  where+  {-# INLINE bindPat #-}+  bindPat = pat @k @t @d @g @a @(CtxOf @k cont) @(TyOf @k cont) @gr++-- | A pattern: a variable, @()@, or a pair of patterns. A triple or quadruple stands for pairs+-- nested to the left, as @a ':**' b ':**' c@ is: @(x, y, z)@ is @((x, y), z)@. Binding it at depth+-- @d@ to a term with context @g@ and type @a@, with a continuation with context @g'@ and type @c@,+-- gives a term with context @gr@, which each instance fixes. A pair or @()@ at a computation,+-- @'Up' a@, runs it and matches its value, so @c@ is then negative.+type Pat :: forall k -> Type -> Nat -> Ctx k -> SYN k -> Ctx k -> SYN k -> Ctx k -> Constraint+class Pat k t d g a g' c gr where+  pat :: Term d g a -> (t -> Term (d + PSize t) g' c) -> Term d gr c++-- | The number of variables a pattern binds on the way, and so the depth it adds.+type PSize :: Type -> Nat+type family PSize t where+  PSize (x, y) = 2 + PSize x + PSize y+  PSize (x, y, z) = PSize ((x, y), z)+  PSize (w, x, y, z) = PSize (((w, x), y), z)+  PSize t = 0++-- The generic instances are incoherent: a variable pattern's type is often still unknown when the+-- instance is chosen, and a pair pattern's type is always a pair by then. The instances at a+-- computation are more specific, so they win once the type is known to be an 'Up'.++-- | The pattern @()@ at a computation of the unit runs it.+instance+  (Dialogue k, KnownObj y, c ~ Not y, Merge g g', gr ~ Union g g')+  => Pat k () d g (Not (Not I) :: SYN k) g' c gr+  where+  {-# INLINE pat #-}+  pat u k = case k () of+    MkTerm t -> runUp @d @g @g' @I @y u (withCtxOb @g' (t . rightUnitor @k @(Interp (Mul g'))))++-- | A pair pattern at a computation runs it and takes its value apart. The value needs no variable+-- of its own: the pattern's variables take the ids it would have taken.+instance+  ( Dialogue k+  , KnownObj a+  , KnownObj y+  , c ~ Not y+  , Pat k (x, y') d '[ '(d, a)] a g' c gp+  , BindVar d a gp r+  , Merge g r+  , gr ~ Union g r+  )+  => Pat k (x, y') d g (Not (Not a) :: SYN k) g' c gr+  where+  {-# INLINE pat #-}+  pat m k = case pat @k @(x, y') @d @'[ '(d, a)] @a @g' @c @gp (var @d @a @d) k of+    MkTerm body -> runUp @d @g @r @a @y m (body . bindVar @d @a @gp @r)++-- | The pattern @()@ uses up a term of the unit type.+instance+  {-# INCOHERENT #-}+  (Monoidal k, a ~ I, KnownObj c, Merge g g', gr ~ Union g g')+  => Pat k () d g (a :: SYN k) g' c gr+  where+  {-# INLINE pat #-}+  pat (MkTerm u) k = case k () of+    MkTerm t -> withSynOb @c (MkTerm (leftUnitor @k @(Interp c) . (u M.** t) . merge @g @g'))++-- | A variable pattern names the right hand side, which is always a variable. If the body does not+-- use it, the binder discards it.+instance {-# INCOHERENT #-} (t ~ Term (DepthOf t) g a, gr ~ g') => Pat k t d g a g' c gr where+  {-# INLINE pat #-}+  pat x k = k (recast x)++instance+  {-# INCOHERENT #-}+  ( Monoidal k+  , a ~ (a1 :** a2)+  , KnownObj a1+  , KnownObj a2+  , Pat k y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g' c gy+  , Pat k x (d + 2) '[ '(d, a1)] a1 gy c gxy+  , d + 2 + PSize x + PSize y ~ d + PSize (x, y)+  , BindVar (d + 1) a2 gxy r1+  , BindVar d a1 r1 r+  , Merge r g+  , gr ~ Union r g+  )+  => Pat k (x, y) d g (a :: SYN k) g' c gr+  where+  {-# INLINE pat #-}+  pat s k =+    split @d @g @gxy @r1 @r+      s+      ( \a b ->+          pat @k @x @(d + 2) @'[ '(d, a1)] @a1 @gy @c @gxy+            a+            (\px -> pat @k @y @(d + 2 + PSize x) @'[ '(d + 1, a2)] @a2 @g' @c @gy b (\py -> k (px, py)))+      )++instance {-# INCOHERENT #-} (Pat k ((x, y), z) d g a g' c gr) => Pat k (x, y, z) d g a g' c gr where+  {-# INLINE pat #-}+  pat s k = pat @k @((x, y), z) @d @g @a @g' @c @gr s (\((px, py), pz) -> k (px, py, pz))++instance {-# INCOHERENT #-} (Pat k (((w, x), y), z) d g a g' c gr) => Pat k (w, x, y, z) d g a g' c gr where+  {-# INLINE pat #-}+  pat s k = pat @k @(((w, x), y), z) @d @g @a @g' @c @gr s (\(((pw, px), py), pz) -> k (pw, px, py, pz))
+ src/Proarrow/Tools/SMC/Internal/Syntax.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": the type expressions of terms, and how they stand for+-- objects. It exports everything, also what the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Syntax where++import Data.Kind (Constraint)+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..))+import Proarrow.Colimit.Initial (HasInitialObject (..))+import Proarrow.Core (CategoryOf (..), obj)+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Object (Obj)++infixl 7 :**+infixl 6 :&&+infixl 6 :||+infixr 5 :->++-- | Type expressions over the objects of @k@: an object of @k@, the unit, the tensor, the+-- internal hom and the negation, and the additives: the product and its unit 'Top', and the+-- coproduct and its unit 'Zero'.+--+-- The negation gives the types a polarity: a type is negative when it is a 'Not', and positive+-- otherwise. A term of a positive type is a value, and a term of a negative type is a consumer+-- of what it negates. 'Proarrow.Tools.SMC.Up' shifts a positive type to a negative one, and 'Dn' a negative type to+-- a positive one, standing for the same object: a term of @'Dn' n@ is a stored term of @n@.+type data SYN k+  = F k+  | I+  | SYN k :** SYN k+  | SYN k :-> SYN k+  | Not (SYN k)+  | Dn (SYN k)+  | SYN k :&& SYN k+  | Top+  | SYN k :|| SYN k+  | Zero++-- | The object of @k@ a type expression stands for.+type Interp :: forall {k}. SYN k -> k+type family Interp s where+  Interp (F a) = a+  Interp I = Unit+  Interp (a :** b) = Interp a ** Interp b+  Interp (a :-> b) = Interp a ~~> Interp b+  Interp (Not a) = Dual (Interp a)+  Interp (Dn a) = Interp a+  Interp (a :&& b) = Interp a && Interp b+  Interp Top = TerminalObject+  Interp (a :|| b) = Interp a || Interp b+  Interp Zero = InitialObject++-- | Type expressions whose 'Interp' is an object, given that their leaves are.+type KnownObj :: forall {k}. SYN k -> Constraint+class (CategoryOf k) => KnownObj (s :: SYN k) where+  withSynOb :: ((Ob (Interp s)) => r) -> r++instance (CategoryOf k, Ob (a :: k)) => KnownObj (F a) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (Monoidal k) => KnownObj (I :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (Monoidal k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :** b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withOb2 @k @(Interp a) @(Interp b) r))++instance (Closed k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :-> b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObExp @k @(Interp a) @(Interp b) r))++instance (KnownObj (a :: SYN k)) => KnownObj (Dn a) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a r++instance (Dialogue k, KnownObj (a :: SYN k)) => KnownObj (Not a) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withObDual @k @(Interp a) r)++instance (HasBinaryProducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :&& b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObProd @k @(Interp a) @(Interp b) r))++instance (HasTerminalObject k) => KnownObj (Top :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++instance (HasBinaryCoproducts k, KnownObj a, KnownObj (b :: SYN k)) => KnownObj (a :|| b) where+  {-# INLINE withSynOb #-}+  withSynOb r = withSynOb @a (withSynOb @b (withObCoprod @k @(Interp a) @(Interp b) r))++instance (HasInitialObject k) => KnownObj (Zero :: SYN k) where+  {-# INLINE withSynOb #-}+  withSynOb r = r++-- | The identity on the object a type expression stands for.+{-# INLINE synOb #-}+synOb :: forall {k} (s :: SYN k). (KnownObj s) => Obj (Interp s)+synOb = withSynOb @s (obj @(Interp s))
+ src/Proarrow/Tools/SMC/Internal/Term.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Internal module of "Proarrow.Tools.SMC": terms and the operations that need no binder. It+-- exports everything, also what the public module keeps hidden.+module Proarrow.Tools.SMC.Internal.Term where++import Data.Kind (Type)+import GHC.TypeNats (Nat, type (+))+import Proarrow.Category.Monoidal (Monoidal (..), associatorInv')+import Proarrow.Category.Monoidal qualified as M+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Monoid (Comonoid (..))+import Prelude (type (~))++import Proarrow.Tools.SMC.Internal.Context+import Proarrow.Tools.SMC.Internal.Syntax++infixl 7 **++-- | A term at binding depth @d@ with context @g@ and type @a@: a morphism from the tensor of+-- the context to @a@.+type Term :: forall {k}. Nat -> Ctx k -> SYN k -> Type+data Term d g a where+  MkTerm :: (Interp (Mul g) ~> Interp a) -> Term d g a++-- | The variable with id @n@: the identity on its type.+{-# INLINE var #-}+var :: forall {k} n (a :: SYN k) d. (CategoryOf k, KnownObj a) => Term d '[ '(n, a)] a+var = withSynOb @a (MkTerm (obj @(Interp a)))++-- | Copy a term whose type is a comonoid: @(x1, x2) <- dup x@. Using a variable twice copies it too,+-- but needs a 'Proarrow.Monoid.CocommutativeComonoid'; 'dup' needs only a 'Comonoid', and its two copies come out+-- in the order of 'comult'.+{-# INLINE dup #-}+dup :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s -> Term d g (s :** s)+dup = lift @s @(s :** s) comult++-- | Discard a term whose type is a comonoid: @() <- drop t@. A variable that is not used is+-- discarded without it.+{-# INLINE drop #-}+drop :: forall {k} (s :: SYN k) d g. (Comonoid (Interp s)) => Term d g s -> Term d g I+drop = lift @s @I counit++-- | Lift a morphism of the target category to a function on terms.+{-# INLINE lift #-}+lift :: forall {k} (a :: SYN k) b d g. (CategoryOf k) => (Interp a ~> Interp b) -> Term d g a -> Term d g b+lift f (MkTerm t) = MkTerm (f . t)++-- | Two terms side by side. A variable both use is copied.+{-# INLINE (**) #-}+(**)+  :: forall {k} d g1 g2 (a :: SYN k) b+   . (Monoidal k, Merge g1 g2)+  => Term d g1 a -> Term d g2 b -> Term d (Union g1 g2) (a :** b)+MkTerm f ** MkTerm g = MkTerm ((f M.** g) . merge @g1 @g2)++-- | Two new variables @n@ and @n + 1@, of types @a@ and @b@, for the body of a 'split' whose+-- context is @g'@: the tensor @a ':**' b@, given from the context @g@, next to @r@, what the body+-- uses besides them.+{-# INLINE push2 #-}+push2+  :: forall {k} n (a :: SYN k) b g' r1 r g+   . (Monoidal k, KnownObj a, KnownObj b, BindVar (n + 1) b g' r1, BindVar n a r1 r, Merge r g)+  => (Interp (Mul g) ~> Interp a ** Interp b)+  -> Interp (Mul (Union r g)) ~> Interp (Mul g')+push2 p =+  withCtxOb @r+    ( withSynOb @b+        ( bindVar @(n + 1) @b @g' @r1+            . (bindVar @n @a @r1 @r M.** obj @(Interp b))+            . associatorInv' (ctxOb @r) (synOb @a) (synOb @b)+            . (ctxOb @r M.** p)+            . merge @r @g+        )+    )++-- | Take a tensor apart: the continuation gets a variable for each side.+{-# INLINE split #-}+split+  :: forall {k} d g g' r1 r (a :: SYN k) b c da db+   . (Monoidal k, KnownObj a, KnownObj b, BindVar (d + 1) b g' r1, BindVar d a r1 r, Merge r g)+  => Term d g (a :** b)+  -> (Term da '[ '(d, a)] a -> Term db '[ '(d + 1, b)] b -> Term (d + 2) g' c)+  -> Term d (Union r g) c+split (MkTerm p) k = case k (var @d @a) (var @(d + 1) @b) of+  MkTerm body -> MkTerm (body . push2 @d @a @b @g' @r1 @r @g p)++-- | The unit, which uses no variables.+{-# INLINE unit #-}+unit :: forall {k} d. (Monoidal k) => Term d ('[] :: Ctx k) I+unit = MkTerm id++-- | The same morphism at another type expression for the same object, and at any depth: between+-- @'F' (a '**' b)@ and @'F' a ':**' 'F' b@, say, so that a pattern can take it apart, or between a+-- type and its 'Dn'. The polarity may change, the morphism does not.+{-# INLINE recast #-}+recast :: forall {k} (a :: SYN k) b d d' g. (Interp a ~ Interp b) => Term d g a -> Term d' g b+recast (MkTerm f) = MkTerm f++type DepthOf :: Type -> Nat+type family DepthOf t where+  DepthOf (Term d g a) = d++type CtxOf :: forall k. Type -> Ctx k+type family CtxOf t where+  CtxOf (Term d g a) = g++type TyOf :: forall k. Type -> SYN k+type family TyOf t where+  TyOf (Term d g a) = a
test/Examples/Cbpv.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-}  -- | Call by push value in "Proarrow.Tools.SMC": values are pure, and effects live in computations,@@ -42,7 +41,7 @@ act_ m = lift @I @(Eff m) (Cps \() k -> m >>= k) unit  -- | A function from a value to an action, as a function from the value to its effect.-effect :: forall m a d g. (Monad m) => (a -> m ()) -> SMC.Term d g (V m a) %1 -> SMC.Term d g (Eff m)+effect :: forall m a d g. (Monad m) => (a -> m ()) -> SMC.Term d g (V m a) -> SMC.Term d g (Eff m) effect f = lift @(V m a) @(Eff m) (Cps \a k -> f a >>= k)  -- | A constant.@@ -65,7 +64,7 @@   () <- effect (say . ("sum " ++) . show) s   ret s' -plus :: forall m d g. SMC.Term d g (V m Int :** V m Int) %1 -> SMC.Term d g (V m Int)+plus :: forall m d g. SMC.Term d g (V m Int :** V m Int) -> SMC.Term d g (V m Int) plus = lift @(V m Int :** V m Int) @(V m Int) (Cps (uncurry (+)))  -- | Two computations made in one order and run in the other. A computation is a value until it is
+ test/Examples/Einsum.hs view
@@ -0,0 +1,134 @@+-- | The pictures of the wiki's einsum page: einsum specifications drawn in 'SVG', with each tensor+-- a box without inputs, and a ring of four tensors read back in three ways.+module Examples.Einsum where++import Data.List (isInfixOf)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding ((**))++import Proarrow.Category.Instance.OpenHypergraph+  ( OPENHG+  , SomeArrow+  , SomeSort+  , Wires+  , openHypergraph+  , readBack+  , readBackWith+  , someArrow+  )+import Proarrow.Category.Instance.OpenHypergraph qualified as OH+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CategoryOf (..))+import Proarrow.Object (SomeOf (..))+import Proarrow.Testing (check)+import Proarrow.Tools.Diagrams.Svg (Options (..), SVG (..), Svg, W (..), defaultOptions, node, renderWith)+import Proarrow.Tools.Einsum (Tensor, einsum)++-- | The wire of an index.+type X c = S '[Wire c]++-- | Caps and cups for the spiders between two wires, and the points moved next to what they meet.+bent :: Options+bent = defaultOptions{bendSpiders = True, slidePoints = True}++draw :: Svg (S as) (S bs) -> String+draw = renderWith bent++a2, b2 :: Tensor '[X "i", X "j"]+a2 = Str (node @'[I] @'[Wire "i", Wire "j"] "A")+b2 = Str (node @'[I] @'[Wire "i", Wire "j"] "B")++a1, b1 :: Tensor '[X "i"]+a1 = Str (node @'[I] @'[Wire "i"] "a")+b1 = Str (node @'[I] @'[Wire "i"] "b")++aii :: Tensor '[X "i", X "i"]+aii = Str (node @'[I] @'[Wire "i", Wire "i"] "A")++bjk :: Tensor '[X "j", X "k"]+bjk = Str (node @'[I] @'[Wire "j", Wire "k"] "B")++-- | The standard examples, each with the file the wiki shows it in.+gallery :: [(FilePath, String)]+gallery =+  [ ("matmul.svg", draw (unStr (einsum @"ij,jk->ik" a2 bjk)))+  , ("transpose.svg", draw (unStr (einsum @"ij->ji" a2)))+  , ("trace.svg", draw (unStr (einsum @"ii->" aii)))+  , ("diagonal.svg", draw (unStr (einsum @"ii->i" aii)))+  , ("sum.svg", draw (unStr (einsum @"ij->" a2)))+  , ("row-sums.svg", draw (unStr (einsum @"ij->i" a2)))+  , ("dot.svg", draw (unStr (einsum @"i,i->" a1 b1)))+  , ("outer.svg", draw (unStr (einsum @"i,j->ij" a1 (Str (node @'[I] @'[Wire "j"] "b") :: Tensor '[X "j"]))))+  , ("entrywise.svg", draw (unStr (einsum @"ij,ij->ij" a2 b2)))+  , ("copy.svg", draw (unStr (einsum @"i->ii" a1)))+  ]++-- * The ring++t :: Tensor '[X "i", X "j", X "x"]+t = Str (node @'[I] @'[Wire "i", Wire "j", Wire "x"] "T")++u :: Tensor '[X "j", X "k", X "k"]+u = Str (node @'[I] @'[Wire "j", Wire "k", Wire "k"] "U")++v :: Tensor '[X "k", X "l"]+v = Str (node @'[I] @'[Wire "k", Wire "l"] "V")++w :: Tensor '[X "l", X "i"]+w = Str (node @'[I] @'[Wire "l", Wire "i"] "W")++-- | The ring as einsum draws it in 'SVG', where every wire has the same size.+ringEinsum :: String+ringEinsum = draw (unStr (einsum @"kl,jkk,ijx,li->li" v u t w))++-- | The nodes of the ring, numbered from 0: i, j, x, k and l.+ringSorts :: [SomeSort SVG]+ringSorts = [Some @(X "i"), Some @(X "j"), Some @(X "x"), Some @(X "k"), Some @(X "l")]++-- | The open hypergraph of the ring with the given boxes, and its boundary the nodes l and i.+ring :: [OH.Box String Int] -> Wires '[] ~> (Wires '[X "l", X "i"] :: OPENHG SVG String)+ring bxs = either error id (openHypergraph ringSorts [] [4, 0] bxs)++-- | The ring with the dimensions of the matrices on the wiki page: i and k have 2, j, x and l have 3.+matSize :: SomeSort SVG -> Int+matSize s = if any (OH.sameSort s) ([Some @(X "j"), Some @(X "x"), Some @(X "l")] :: [SomeSort SVG]) then 3 else 2++ringArrow :: String -> SomeArrow SVG+ringArrow x = case x of+  "T" -> someArrow t+  "U" -> someArrow u+  "V" -> someArrow v+  "W" -> someArrow w+  _ -> someArrow (v ** u ** t ** w)++drawRead :: Either String (Strictified '[] '[X "l", X "i"]) -> String+drawRead = either error (draw . unStr)++-- | The ring as einsum reads it back with the sizes of the matrices.+ringSized :: String+ringSized =+  drawRead+    ( readBackWith+        matSize+        ringArrow+        (ring [OH.Box "V" [] [3, 4], OH.Box "U" [] [1, 3, 3], OH.Box "T" [] [0, 1, 2], OH.Box "W" [] [4, 0]])+    )++-- | The ring with everything tensored first: one box that is all four tensors side by side, whose+-- ports are joined afterwards.+ringNaive :: String+ringNaive = drawRead (readBack ringArrow (ring [OH.Box "VUTW" [] [3, 4, 1, 3, 3, 0, 1, 2, 4, 0]]))++-- | The ring pictures, each with the file the wiki shows it in.+ringPictures :: [(FilePath, String)]+ringPictures = [("ring-naive.svg", ringNaive), ("ring-einsum.svg", ringEinsum), ("ring-sized.svg", ringSized)]++test :: TestTree+test =+  testGroup+    "Einsum pictures"+    [ testProperty ("draws " ++ file) (check "not an SVG document" ("<svg" `isInfixOf` svg))+    | (file, svg) <- gallery ++ ringPictures+    ]
test/Examples/LinearLogic.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}  -- | The linear logic connectives of "Proarrow.Tools.SMC", each tested where it lives. --@@ -26,7 +27,7 @@ import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..)) import Proarrow.Category.Instance.Linear (LINEAR (..), unLinear) import Proarrow.Category.Instance.Linear qualified as Lin-import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), type (**))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), rightUnitorWith, type (**)) import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), combineDual) import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), Par, doubleNegInvDefault, par, parSwap, weakDistL, weakDistR) import Proarrow.Category.Monoidal.Distributive (Distributive (..))@@ -39,37 +40,89 @@ import Proarrow.Promonad.Cont (Cont (..)) import Proarrow.Testing (check, genNamed) import Proarrow.Tools.Diagrams.Svg qualified as Svg-import Proarrow.Tools.SMC-  ( SYN (F, Not, (:**))-  , annihilate-  , bothWaysT+import Proarrow.Tools.SMC (SYN (F, Not, (:&&), (:**)), annihilate, cont, ret, toSMC, (|>), type (:##))+import Proarrow.Tools.SMC qualified as SMC+import Proarrow.Tools.SMC.Examples+  ( bothWaysT   , combineDualT-  , cont   , contraT   , distT   , dneT   , dniT   , loopCC   , parSwapT-  , ret   , rotT   , snakeDualT   , snakeT   , swapEitherT-  , toSMC   , weakDistT-  , (|>)-  , type (:##)   )-import Proarrow.Tools.SMC qualified as SMC import Props.FinRel ()  test :: TestTree-test = testGroup "Linear logic (Proarrow.Tools.SMC)" [duality, classical, additives, parTests]+test = testGroup "Linear logic (Proarrow.Tools.SMC)" [resources, duality, classical, additives, parTests]  type F1 = FR (S Z) type F2 = FR (S (S Z)) type F3 = FR (S (S (S Z)))++-- * Copying and discarding++-- In 'FinRel' copying is the diagonal, which a relation that is not a function does not commute+-- with, so binding a term to a variable and using the term twice give different relations. The+-- pattern @(x, _)@ takes a term apart, which Prelude's @fst@ would not.++{- HLINT ignore resources "Use fst" -}+resources :: TestTree+resources =+  testGroup+    "Copying and discarding"+    [ testProperty "a variable used twice is copied (FinRel 2)" $+        check "differs from comult" (toSMC @(F F2) @(F F2 :** F F2) (\x -> x SMC.** x) == comult)+    , testProperty "an unused variable is discarded (FinRel 2, 3)" $+        check+          "differs from the counit"+          (toSMC @(F F2 :** F F3) @(F F2) (\(x, _) -> x) == rightUnitorWith @F2 (counit @F3))+    , testProperty "a bound term is computed once and its value copied (FinRel 2, 3)" $ do+        h <- genNamed @(F2 ~> F3) "h"+        check+          "differs from comult . h"+          ( toSMC @(F F2) @(F F3 :** F F3)+              ( \x -> SMC.do+                  y <- SMC.lift h x+                  y SMC.** y+              )+              == comult . h+          )+    , testProperty "a term used twice is computed twice (FinRel 2, 3)" $ do+        h <- genNamed @(F2 ~> F3) "h"+        check+          "differs from (h ** h) . comult"+          ( toSMC @(F F2) @(F F3 :** F F3) (\x -> SMC.lift h x SMC.** SMC.lift h x)+              == (h ** h) . comult+          )+    , testProperty "a fed back variable of a rec block that is also used after it is copied" $+        check "differs" (case recCopyT 1 of (b, u) -> b == [1, 1, 1] && take 4 u == [1, 1, 1, 1])+    , testProperty "a variable of a rec block that nothing uses is discarded" $+        check "differs" (take 4 (recDropT 1) == [1, 1, 1, 1])+    , testProperty "an alternative that does not use a variable discards it (FinRel 2, 3)" $ do+        let t = toSMC @(F F2 :** F F3) @(F F2 :&& (F F2 :** F F3)) \(x, y) -> SMC.with x (x SMC.** y)+        check "fst differs from the counit" (fst @_ @F2 @(F2 ** F3) . t == rightUnitorWith @F2 (counit @F3))+        check "snd differs from id" (snd @_ @F2 @(F2 ** F3) . t == id)+    ]++-- | A @rec@ block whose fed back list is also passed on, so it is copied: the list is @1 : u@ and+-- the result its first three elements next to the list itself.+recCopyT :: Int -> ([Int], [Int])+recCopyT = toSMC @(F Int) @(F [Int] :** F [Int]) \a -> SMC.do+  rec (b, u) <- SMC.lift @(F Int :** F [Int]) @(F [Int] :** F [Int]) (\(x, us) -> (take 3 us, x : us)) (a SMC.** u)+  b SMC.** u++-- | A @rec@ block with a variable that nothing uses, which is discarded.+recDropT :: Int -> [Int]+recDropT = toSMC @(F Int) @(F [Int]) \a -> SMC.do+  rec (_b, u) <- SMC.lift @(F Int :** F [Int]) @(F [Int] :** F [Int]) (\(x, us) -> (take 3 us, x : us)) (a SMC.** u)+  u  -- * Duals
test/Examples/Sessions.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-}  -- | The internet commerce example of Wadler's /Propositions as Sessions/ (JFP version), with@@ -29,11 +28,11 @@ import Proarrow.Core (CategoryOf (..), Promonad (..), obj) import Proarrow.Testing (check) import Proarrow.Tools.SMC-  ( KnownCtx+  ( Interp+  , KnownCtx   , SYN (F, I, Not, (:**), (:||))   , Up   , caseOf-  , closed   , cont   , inl   , inr@@ -69,6 +68,10 @@ run :: forall a. (Unit ~> Dual (Dual (L (Ur a)))) -> a run p = counitUr (unLinear (doubleNeg @LINEAR @(L (Ur a)) . p) ()) +-- | A process with no free channels, compiled on its own, for use in any other.+piece :: forall (a :: SYN LINEAR) d. (Unit ~> Interp a) -> SMC.Term d '[] a+piece p = lift p unit+ -- * Messages  type Name = L (Ur String)@@ -89,13 +92,13 @@  -- | @x[u].(put-name_u | x[v].(put-credit_v | x ↔ r))@: send the name on @u@ and the card on @v@, -- and forward the rest of @x@, where the receipt arrives, to @r@.-buyer :: (KnownCtx g) => SMC.Term d g (Not (F Receipt)) %1 -> SMC.Term d g Buy+buyer :: (KnownCtx g) => SMC.Term d g (Not (F Receipt)) -> SMC.Term d g Buy buyer r = put "tea" ** put 1234 ** r  -- | @x(u).x(v).compute_{u,v,x}@: receive the name and the card, and send the receipt where it -- should go. seller :: SMC.Term d '[] Sell-seller = closed $ cont \(name, credit, toBuyer) -> compute (name ** credit) |> toBuyer+seller = piece $ toSMC \() -> cont \(name, credit, toBuyer) -> compute (name ** credit) |> toBuyer  -- | @νx.(buy | sell)@, with the buyer's receipt as the result. deal :: Unit ~> Dual (Dual Receipt)@@ -112,16 +115,16 @@ type Quote = Not Shop  -- | @x[u].(put-name_u | x ↔ r)@.-shopper :: (KnownCtx g) => SMC.Term d g (Not (F Price)) %1 -> SMC.Term d g Shop+shopper :: (KnownCtx g) => SMC.Term d g (Not (F Price)) -> SMC.Term d g Shop shopper r = put "tea" ** r  -- | @x(u).lookup_{u,x}@. quoter :: SMC.Term d '[] Quote-quoter = closed $ cont \(name, toShopper) -> lookupPrice name |> toShopper+quoter = piece $ toSMC \() -> cont \(name, toShopper) -> lookupPrice name |> toShopper  -- | @νx.(shop | quote)@. ask :: Unit ~> Dual (Dual Price)-ask = toSMC @I @(Up (F Price)) \() -> cont \r -> shopper r |> quoter+ask = toSMC \() -> cont \r -> shopper r |> quoter  -- * Choosing @@ -131,15 +134,15 @@ type Select = Buy :|| Shop  choice :: SMC.Term d '[] (Not Select)-choice = closed $ cont \x -> caseOf unit x (\((), b) -> b |> seller) (\((), s) -> s |> quoter)+choice = piece $ toSMC \() -> cont \x -> caseOf x (|> seller) (|> quoter)  -- | @νx.(x[inl].buy | choice)@. selectBuy :: Unit ~> Dual (Dual Receipt)-selectBuy = toSMC @I @(Up (F Receipt)) \() -> cont \r -> inl (buyer r) |> choice+selectBuy = toSMC \() -> cont \r -> inl (buyer r) |> choice  -- | @νx.(x[inr].shop | choice)@, which tells the price instead. selectShop :: Unit ~> Dual (Dual Price)-selectShop = toSMC @I @(Up (F Price)) \() -> cont \r -> inr (shopper r) |> choice+selectShop = toSMC \() -> cont \r -> inr (shopper r) |> choice  -- * A broker @@ -147,13 +150,13 @@ -- par. The consumer of the buyer's channel is a computation that produces the order: binding it -- reads the order, which is then placed with the seller, with the receipt passed back with a note. broker :: SMC.Term d '[] (Not Buy :## Buy)-broker = closed $ cont \(fromBuyer, toSeller) -> SMC.do+broker = piece $ toSMC @I @(Not Buy :## Buy) \() -> cont \(fromBuyer, toSeller) -> SMC.do   (name, credit, toBuyer) <- fromBuyer   name ** credit ** cont (\receipt -> annotate receipt |> toBuyer) |> toSeller  -- | @νx.νy.(buy | broker | sell)@. The buyer's side is handed to the broker as a computation. brokeredDeal :: Unit ~> Dual (Dual Receipt)-brokeredDeal = toSMC @I @(Up (F Receipt)) \() -> cont \r -> ret (buyer r) ** seller |> broker+brokeredDeal = toSMC \() -> cont \r -> ret (buyer r) ** seller |> broker  -- * By hand @@ -201,11 +204,11 @@ put :: forall a d. a -> SMC.Term d '[] (F (L (Ur a))) put x = lift @I @(F (L (Ur a))) (Linear \() -> Ur x) unit -compute :: SMC.Term d g (F Name :** F Credit) %1 -> SMC.Term d g (F Receipt)+compute :: SMC.Term d g (F Name :** F Credit) -> SMC.Term d g (F Receipt) compute = lift @(F Name :** F Credit) @(F Receipt) (Linear \(Ur n, Ur c) -> Ur (n ++ ", paid with " ++ show c)) -lookupPrice :: SMC.Term d g (F Name) %1 -> SMC.Term d g (F Price)+lookupPrice :: SMC.Term d g (F Name) -> SMC.Term d g (F Price) lookupPrice = lift @(F Name) @(F Price) (Linear \(Ur n) -> Ur (length n)) -annotate :: SMC.Term d g (F Receipt) %1 -> SMC.Term d g (F Receipt)+annotate :: SMC.Term d g (F Receipt) -> SMC.Term d g (F Receipt) annotate = lift @(F Receipt) @(F Receipt) (Linear \(Ur s) -> Ur (s ++ " (via broker)"))
test/Examples/SimplyTypedLambdaCalculus.hs view
@@ -36,8 +36,8 @@   ) import Proarrow.Testing   ( GenTotal (..)-  , MkSomeList (..)-  , Some (..)+  , Some+  , SomeOf (..)   , SomeProfunctorElt (..)   , Testable (..)   , TestableProfunctor (..)@@ -48,6 +48,7 @@   , genObSuchThat   , genSomeDef   , isGenNonEmpty+  , mkSomeList   , oneElem   , oneOfTotal   )@@ -387,12 +388,12 @@ type TyPalette = '[K, K :=> K, K :=> (K :=> K)]  tyPalette :: [Some TY]-tyPalette = mkSomeList @TY @TyPalette+tyPalette = mkSomeList @TyPalette  type ConPalette = '[E, E :> K, (E :> K) :> K]  conPalette :: [Some CON]-conPalette = mkSomeList @CON @ConPalette+conPalette = mkSomeList @ConPalette  -- ** Total type-directed generators
test/Examples/Toffoli.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE LinearTypes #-} {-# LANGUAGE QualifiedDo #-}  -- | The Toffoli gate example from the @linear-smc@ library (the examples of /Evaluating Linear@@ -64,11 +63,11 @@   (b4, a4) <- cnot (t b3) (t' a3)   a4 ** b4 ** h (t x4)   where-    h, t, t' :: Term d g (F q) %1 -> Term d g (F q)+    h, t, t' :: Term d g (F q) -> Term d g (F q)     h = lift (hadamardG gates)     t = lift (tG gates)     t' = lift (tInvG gates)-    cnot :: (Merge g1 g2) => Term d g1 (F q) %1 -> Term d g2 (F q) %1 -> Term d (Union g1 g2) (F q :** F q)+    cnot :: (Merge g1 g2) => Term d g1 (F q) -> Term d g2 (F q) -> Term d (Union g1 g2) (F q :** F q)     cnot c x = lift (cnotG gates) (c ** x)  -- | The same circuit written directly with the monoidal structure, for comparison. The wires are
test/Examples/UntypedLambdaCalculus.hs view
@@ -18,7 +18,8 @@ import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..)) import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , Some+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)@@ -229,9 +230,12 @@     , [liftA2 cons s t | SS <- [sing @b], Just s <- [genDepthSub (d - 1)], Just t <- [genDepthTm (d - 1)]]     ]       ++ [ [liftA2 (.) l r | Just l <- [genDepthSub @m @b (d - 1)], Just r <- [genDepthSub (d - 1)]]-         | Some @m <- [Some @Z, Some @(S Z), Some @(S (S Z)), Some @(S (S (S Z)))]+         | Some @m <- smallContexts          ] +smallContexts :: [Some CON]+smallContexts = [Some @Z, Some @(S Z), Some @(S (S Z)), Some @(S (S (S Z)))]+ genDepthTm :: forall a. (Ob a) => Int -> Maybe (Gen (Tm a)) genDepthTm 0 = Nothing genDepthTm d =@@ -241,7 +245,7 @@     , [liftA2 ($$) l r | Just l <- [genDepthTm (d - 1)], Just r <- [genDepthTm (d - 1)]]     ]       ++ [ [liftA2 lmap s t | Just t <- [genDepthTm @b (d - 1)], Just s <- [genDepthSub (d - 1)]]-         | Some @b <- [Some @Z, Some @(S Z), Some @(S (S Z)), Some @(S (S (S Z)))]+         | Some @b <- smallContexts          ]  oneof' :: [[Gen a]] -> Maybe (Gen a)
test/Main.hs view
@@ -8,6 +8,7 @@ import Examples.Cbpv qualified as Cbpv import Examples.CustomLaws qualified as CustomLaws import Examples.Database qualified as Database+import Examples.Einsum qualified as Einsum import Examples.Free qualified as FreeExample import Examples.Graph qualified as Graph import Examples.IntComposition qualified as IntComposition@@ -34,18 +35,21 @@ import Props.IntConstruction qualified as IntConstruction import Props.Kleisli qualified as Kleisli import Props.Mat qualified as Mat+import Props.OpenHypergraph qualified as OpenHypergraph import Props.Optic.FinRel qualified as OpticFinRel import Props.Optic.Hask qualified as Optic import Props.Optic.Linear qualified as OpticLinear import Props.Ordinal qualified as Ordinal import Props.Paths qualified as Paths import Props.PointedHask qualified as PointedHask+import Props.SMC qualified as SMC import Props.Sheaf qualified as Sheaf import Props.Sheaf.Chain qualified as SheafChain import Props.Sheaf.Collage qualified as SheafCollage import Props.Simplex qualified as Simplex import Props.Span qualified as Span import Props.Svg qualified as Svg+import Props.TensorNetwork qualified as TensorNetwork import Props.ZX qualified as ZX  main :: IO ()@@ -58,6 +62,7 @@           [ Bool.test           , Discrete.test           , Cospan.test+          , OpenHypergraph.test           , Cost.test           , DPO.test           , Dot.test@@ -82,14 +87,17 @@           , SheafChain.test           , SheafCollage.test           , Simplex.test+          , SMC.test           , Span.test           , Svg.test+          , TensorNetwork.test           , ZX.test           ]       , testGroup           "Examples"           [ CustomLaws.test           , Database.test+          , Einsum.test           , FreeExample.test           , Graph.test           , STLC.test
test/Props/Bool.hs view
@@ -28,7 +28,7 @@ import Proarrow.Category.Instance.Product ((:**:) (..)) import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , SomeOf (..)   , SomeProfunctorElt (..)   , Testable (..)   , TestableProfunctor (..)
test/Props/Cospan.hs view
@@ -9,13 +9,13 @@ import Test.Tasty (TestTree, testGroup) import Prelude (Bool (..), Maybe (..), pure, zip, ($), (&&), (++), (<$>), (<*>), (||)) -import Proarrow.Category.Instance.Cospan (COSPAN (..), Cospan (..))+import Proarrow.Category.Instance.Cospan (COSPAN, CS, Cospan, pattern Cospan) import Proarrow.Category.Instance.FinSet (FINSET (..), findIso, unFinSet) import Proarrow.Core (CAT, CategoryOf (..), UN, (//), (\\))  import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)
test/Props/Dot.hs view
@@ -20,8 +20,9 @@ import Prelude hiding (elem, fst, id, snd, (.))  import Proarrow.Category.Monoidal (withOb2)-import Proarrow.Category.Monoidal.Strictified (IsList (..))+import Proarrow.Category.Monoidal.Strictified (IsList (..), withIsListOf) import Proarrow.Core (CategoryOf (..), Promonad (..), UN)+import Proarrow.Object (withListOf) import Proarrow.Tools.Diagrams.Dot   ( DOT (..)   , Dot (..)@@ -40,7 +41,8 @@  import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , Some+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)@@ -74,10 +76,7 @@     ]  foldSome :: [Some Symbol] -> Some DOT-foldSome [] = Some @(D '[])-foldSome [Some @n] = Some @(D '[n])-foldSome (Some @n : Some @m : rest) = case foldSome (Some @m : rest) of-  Some @(D ns) -> withIsList2 @'[n] @ns (Some @(D (n ': ns)))+foldSome ss = withListOf ss \ @ns l -> withIsListOf l (Some @(D ns))  instance Testable Symbol where   genSome = genSomeDef @'["A", "B", "C", "D", "E"]
test/Props/FinHask.hs view
@@ -24,7 +24,7 @@  import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)
test/Props/FinRel.hs view
@@ -18,7 +18,7 @@ import Proarrow.Promonad.Writer (Writer)  import Proarrow.Testing-  ( Some (..)+  ( SomeOf (..)   , SomeProfunctorElt (..)   , Testable (..)   , TestableProfunctor (..)
test/Props/Free.hs view
@@ -39,8 +39,8 @@  import Proarrow.Testing   ( GenTotal (..)-  , MkSomeList (..)-  , Some (..)+  , Some+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)@@ -49,6 +49,7 @@   , expect   , genNamed   , genSomeDef+  , mkSomeList   , oneOfTotal   , testEq   )@@ -234,7 +235,7 @@ type Intermediates = TermF ': InitF ': Palette  intermediates :: [Some FREEKIND]-intermediates = mkSomeList @FREEKIND @Intermediates+intermediates = mkSomeList @Intermediates  -- | Generate a random term between two (given) object shapes. Most branches recurse -- structurally on a strictly smaller sub-shape of the source or target, so they always
+ test/Props/OpenHypergraph.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Open hypergraphs with wires sorted by objects of 'Mat'. Equality is 'isomorphic', so the laws+-- hold up to renaming nodes and reordering boxes, and the examples check that terms equal by the+-- Frobenius laws give isomorphic hypergraphs and that others do not.+module Props.OpenHypergraph (test) where++import Control.Monad (replicateM)+import Data.List qualified as List+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as M+import Data.Type.Nat (Nat2, Nat3)+import Data.Universe.Class (Finite (..))+import Test.Falsify (Property, testFailed)+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (elem, id, mappend, mempty, (**), (.))++import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..))+import Proarrow.Category.Instance.FinHask (FINHASK (..), FinHask (..))+import Proarrow.Category.Instance.Mat (Mat (..), MatK (..))+import Proarrow.Category.Instance.OpenHypergraph+  ( Box (..)+  , Boxes (..)+  , OPENHG+  , SomeArrow+  , Sorted+  , WireSorts+  , Wires+  , box+  , isomorphic+  , prim+  , readBack+  , sameSort+  , simplify+  , someArrow+  , sortList+  , sortOf+  )+import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Hypergraph (Sized (..), cap, cup)+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), singleton)+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), UN, obj)+import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Testing+  ( SomeOf (..)+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , check+  , genNamed+  , genSomeDef+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.Einsum (einsum)+import Proarrow.Tools.SMC.Examples (hadamardT, matMulT, traceIdxT)+import Props.Mat ()+import Props.SMC (name)++type OH = OPENHG (MatK Int) String++-- | One wire of each sort.+type I = Wires '[M2] :: OH++type B = Wires '[M3] :: OH++test :: TestTree+test =+  testGroup+    "Open hypergraphs"+    [ testCategory @OH+    , testDagger @OH+    , testMonoidal_ @OH+    , testSymMonoidal_ @OH+    , testClosed_ @OH+    , testDialogue_ @OH+    , testStarAutonomous_ @OH+    , testIsoMix_ @OH+    , testCompactClosed_ @OH+    , testCopyDiscard_ @OH+    , testHypergraph_ @OH+    , testGroup+        "the Frobenius laws"+        [ testProperty "matrix multiplication in index notation is composition" $+            check "not isomorphic" (isomorphic (matMulT f h) (h . f))+        , testProperty "the trace in index notation is the cap after the cup" $+            check "not isomorphic" (isomorphic (traceIdxT g) (cap @I . (g ** obj @I) . cup @I))+        , testProperty "the entrywise product in index notation is mappend after the two after comult" $+            check "not isomorphic" (isomorphic (hadamardT f f') (mappend @B . (f ** f') . comult @I))+        , testProperty "speciality: copying then merging is the identity" $+            check "not isomorphic" (isomorphic (mappend @I . comult @I) id)+        , testProperty "a closed loop is not the empty diagram" $+            check "isomorphic" (not (isomorphic (counit @I . mempty @I) id))+        , testProperty "closed loops of different sorts differ" $+            check "isomorphic" (not (isomorphic (counit @I . mempty @I) (counit @B . mempty @B)))+        , testProperty "composition is not commutative" $+            check "isomorphic" (not (isomorphic (g . g') (g' . g)))+        , testProperty "einsum ij,jk is composition" $+            check "not isomorphic" (isomorphic (unStr (einsum @"ij,jk" (name f) (name h))) (unStr (name (h . f))))+        ]+    , testGroup+        "read-back in Mat Int"+        [ testProperty "matrix multiplication in index notation reads back as composition (2, 3)" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            gm <- genNamed @(M3 ~> M2) "g"+            let Str m = simplify (matMulT (prim (singleton fm)) (prim (singleton gm)))+            check "differs from g . f" (unMat m == unMat (gm . fm))+        , testProperty "the trace reads back as the trace (3)" $ do+            gm <- genNamed @(M3 ~> M3) "g"+            m <- readBackOr (\_ -> someArrow (singleton gm)) (traceIdxT (box @_ @'[M3] @'[M3] "g"))+            check "differs" (unMat m == unMat (traceIdxT gm))+        , testProperty "the entrywise product reads back as the entrywise product (2, 3)" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            gm <- genNamed @(M2 ~> M3) "g"+            let interp x = if x == "f" then someArrow (singleton fm) else someArrow (singleton gm)+            m <- readBackOr interp (hadamardT (box @_ @'[M2] @'[M3] "f") (box @_ @'[M2] @'[M3] "g"))+            check "differs" (unMat m == unMat (hadamardT fm gm))+        , testProperty "einsum ij,jk reads back as the name of the composite (2, 3)" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            gm <- genNamed @(M3 ~> M2) "g"+            let interp x = if x == "f" then someArrow (singleton fm) else someArrow (singleton gm)+            m <-+              readBackOr+                interp+                (unStr (einsum @"ij,jk" (name (box @String @'[M2] @'[M3] "f")) (name (box @String @'[M3] @'[M2] "g"))))+            check "differs" (unMat m == unMat ((obj @M2 ** (gm . fm)) . cup @M2))+        , testProperty "a node made in two layers is merged, not discarded (2, 3)" $ do+            am <- genNamed @(Unit ~> M3) "a"+            hm <- genNamed @(Unit ~> M2) "h"+            gm <- genNamed @(M2 ~> M3) "g"+            let interp x = case x of+                  "a" -> someArrow @'[] @'[M3] (Str am)+                  "h" -> someArrow @'[] @'[M2] (Str hm)+                  _ -> someArrow (singleton gm)+            m <-+              readBackOr+                interp+                ( cap @(Wires '[M3])+                    . (box @_ @'[] @'[M3] "a" ** (box @_ @'[M2] @'[M3] "g" . box @_ @'[] @'[M2] "h"))+                )+            check "differs" (unMat m == unMat (cap @M3 . (am ** (gm . hm)) . leftUnitorInv))+        , testProperty "two states merged, then a box on the merge (2, 3)" $ do+            am <- genNamed @(Unit ~> M3) "a"+            bm <- genNamed @(Unit ~> M3) "b"+            gm <- genNamed @(M3 ~> M2) "g"+            let interp x = case x of+                  "a" -> someArrow @'[] @'[M3] (Str am)+                  "b" -> someArrow @'[] @'[M3] (Str bm)+                  _ -> someArrow (singleton gm)+            m <-+              readBackOr+                interp+                (box @_ @'[M3] @'[M2] "g" . mappend @(Wires '[M3]) . (box @_ @'[] @'[M3] "a" ** box @_ @'[] @'[M3] "b"))+            check "differs" (unMat m == unMat (gm . mappend @M3 . (am ** bm) . leftUnitorInv))+        , testProperty "a closed loop reads back as the dimension (3)" $ do+            m <- readBackOr (\_ -> error "no boxes") (counit @(Wires '[M3] :: OM) . mempty @(Wires '[M3]))+            check "not 3" (unMat m == unMat (counit @M3 . mempty @M3))+        ]+    , testGroup+        "read-back in SVG"+        [ testProperty "matrix multiplication in index notation reads back with no points" $ do+            let d = node @'[Wire "A"] @'[Wire "A"] "f"+                t = matMulT (box @_ @'[A] @'[A] "f") (box @_ @'[A] @'[A] "f") :: Wires '[A] ~> (Wires '[A] :: OPENHG SVG String)+            case readBack (\_ -> someArrow (singleton d)) t of+              Right (Str r) -> check "points are drawn" (points (render r) == 0)+              Left e -> testFailed e+        , testProperty "the trace reads back with one spider on each side of the loop" $ do+            let d = node @'[Wire "A"] @'[Wire "A"] "h"+            case readBack+              (\_ -> someArrow (singleton d))+              (traceIdxT (box @_ @'[A] @'[A] "h") :: Wires '[] ~> (Wires '[] :: OPENHG SVG String)) of+              Right (Str r) -> check "not four points" (points (render r) == 4)+              Left e -> testFailed e+        ]+    ]+  where+    points = length . filter ("<circle" `List.isPrefixOf`) . List.tails+    f = box @_ @'[M2] @'[M3] "f"+    f' = box @_ @'[M2] @'[M3] "f'"+    h = box @_ @'[M3] @'[M2] "h"+    g = box @_ @'[M2] @'[M2] "g"+    g' = box @_ @'[M2] @'[M2] "g'"++type M2 = M Nat2 :: MatK Int+type M3 = M Nat3 :: MatK Int+type OM = OH+type A = S '[Wire "A"]++-- | The read-back in Mat Int as a matrix, failing the property if it fails.+readBackOr+  :: forall a b+   . (String -> SomeArrow (MatK Int))+  -> (a :: OM) ~> b+  -> Property (Fold (WireSorts a) ~> Fold (WireSorts b))+readBackOr interp t = case readBack interp t of+  Right (Str m) -> pure m+  Left e -> testFailed e++instance Testable OH where+  showOb @a = "Wires " ++ show (fmap (\(Some @x) -> sizeOf @(MatK Int) @x) (sortList @(MatK Int) @(WireSorts a)))+  genSome =+    genSomeDef+      @'[ Wires '[]+        , Wires '[M2]+        , Wires '[M2, M3]+        , Wires '[M3, M3, M2]+        , Wires '[M3, M2, M2]+        ]++instance (Ob a, Ob b) => TestingEqShow (DecCospan a (b :: OH)) where+  eqP x y = pure (isomorphic x y)+  showP (DecCospan (Sub (FinHask l)) (Sub (FinHask r)) (Boxes bs)) =+    "DecCospan " ++ show l ++ " " ++ show r ++ " " ++ show bs++-- | A random apex from the palette, legs into it that keep the sorts of the ports, and up to two+-- boxes on its nodes.+instance (Ob a, Ob b) => TestableType (DecCospan a (b :: OH)) where+  gen = GenNonEmpty loop+    where+      loop = do+        c <- genSome @OH+        case c of+          Some @(DC (SUB (FH n))) -> do+            let nodesOfSort x = [y | y <- universeF @n, sameSort (sortOf @(MatK Int) @(FH n) y) x]+                leg :: forall p. (Sorted (MatK Int) (FH p)) => Maybe [(p, NonEmpty n)]+                leg =+                  traverse (\x -> case nodesOfSort (sortOf @(MatK Int) @(FH p) x) of [] -> Nothing; y : ys -> Just (x, y :| ys)) universeF+            case (leg @(UN FH (UN SUB (UN DC a))), leg @(UN FH (UN SUB (UN DC b)))) of+              (Just la, Just lb) -> do+                l <- traverse (\(x, ys) -> (x,) <$> elem ys) la+                r <- traverse (\(x, ys) -> (x,) <$> elem ys) lb+                bs <- case universeF @n of+                  [] -> pure []+                  n0 : ns -> do+                    k <- elem [0 .. 2]+                    replicateM k do+                      x <- elem ["f", "g"]+                      ni <- elem [0 .. 2]+                      no <- elem [0 .. 2]+                      Box x <$> replicateM ni (elem (n0 :| ns)) <*> replicateM no (elem (n0 :| ns))+                pure (DecCospan (Sub (FinHask (M.fromList l))) (Sub (FinHask (M.fromList r))) (Boxes bs))+              _ -> loop++instance TestableProfunctor (DecCospan :: CAT OH)
test/Props/Optic/Hask.hs view
@@ -11,6 +11,7 @@ module Props.Optic.Hask where  import Data.Bifunctor (bimap, first, second)+import Data.Bitraversable (bitraverse) import Data.Maybe (maybeToList) import Data.Tuple (swap) import Data.Type.Nat (Nat2, Nat3)@@ -53,9 +54,10 @@   , par1Optic   , plusOptic   , toPTraversal+  , toPTraversalFull   , u1Optic   )-import Proarrow.Optic.Traversal (TravFl, Traversal, traverseOf)+import Proarrow.Optic.Traversal (TravFl, Traversal, fromTravVL, traverseOf, traversed)  import Proarrow.Category.Instance.Opposite (OPPOSITE (..)) import Proarrow.Functor (Prelude (..))@@ -118,6 +120,10 @@ lensToGetter :: (CategoryOf k) => Lens (s :: k) t a b -> Getter s t a b lensToGetter = O.convert +-- | Both components of a pair, in van Laarhoven form.+both :: (Applicative f) => (a -> f b) -> (a, a) -> f (b, b)+both k = bitraverse k k+ lensToTraversal :: (CategoryOf k) => Lens (s :: k) t a b -> Traversal s t a b lensToTraversal = O.convert @@ -378,6 +384,26 @@         (\ss -> unPrelude (unStar (powerGrateOf triK (Star (Prelude . okIf))) ss))         aggTriple     , propFnEq @(Bool, Bool) "re lens as review" (review (O.re _1)) fst+    , propFnEq @(Maybe Bool)+        "van Laarhoven traversal as setter"+        (over (fromTravVL traverse) not)+        (fmap not)+    , propFnEq @[Bool]+        "van Laarhoven traversal as fold (through the list traversal)"+        (foldMapOf (fromTravVL traverse) (: []))+        id+    , propFnEq @(Bool, Bool)+        "van Laarhoven traversal of a pair, eliminated as a profunctor traversal"+        (unPrelude . unStar (traverseOf (toPTraversalFull (fromTravVL both)) (Star (Prelude . Just . not))))+        (\(a, b) -> Just (not a, not b))+    , propFnEq @[Bool]+        "list traversal through the generic carrier"+        (foldMapOf (toPTraversalFull (traversed @(Star []))) (: []))+        id+    , propFnEq @[Bool]+        "van Laarhoven list traversal through the generic carrier"+        (unPrelude . unStar (traverseOf (toPTraversalFull (fromTravVL traverse)) (Star (Prelude . Just . not))))+        (Just . map not)     , propFnEq @Bool "re prism as getter" (view (O.re _Just)) Just     , propFnEq @Bool "re iso as getter" (view (O.re notIso)) not     , propFnEq @(Bool, Bool) "re re lens as getter" (view (reReLens _1)) fst
+ test/Props/SMC.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE QualifiedDo #-}++-- | Index notation in "Proarrow.Tools.SMC", checked against the structure of the category: in+-- 'FinRel', where a sum over an index is "there is", and in 'Mat' over 'Int', where it is a sum of+-- numbers.+module Props.SMC (test, name) where++import Data.Containers.ListUtils (nubOrd)+import Data.Foldable (toList)+import Data.Map.Strict qualified as M+import Data.Type.Nat (Nat (..), Nat2, Nat3)+import Data.Vec.Lazy (Vec (..))+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (TestOptions (..), testProperty, testPropertyWith)+import Prelude hiding (id, mappend, mempty, (**), (.))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.FinRel (FINREL (..))+import Proarrow.Category.Instance.Mat (Mat (..), MatK (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, cap, cup)+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj, (\\))+import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Testing (check, genNamed)+import Proarrow.Testing.Laws (defaultTestOptions)+import Proarrow.Tools.Einsum (EinsumType, Tensor, einsum)+import Proarrow.Tools.SMC (SYN (..), delta, lift, sumOver, toSMC, unit, (*^))+import Proarrow.Tools.SMC qualified as SMC+import Proarrow.Tools.SMC.Examples (hadamardT, matMulT, traceIdxT)+import Props.FinRel ()+import Props.Mat ()++type F2 = FR (S (S Z))+type F3 = FR (S (S (S Z)))+type F4 = FR (S (S (S (S Z))))++type M2 = M Nat2 :: MatK Int+type M3 = M Nat3 :: MatK Int++-- | The transpose in index notation: the entry at @j@ and @i@ is the entry of @f@ at @i@ and @j@.+transposeT :: Mat M2 M3 -> Mat M3 M2+transposeT f = toSMC @(F M3) \j -> sumOver @(F M2) \i -> delta (lift f i) j *^ i++-- | A morphism as a tensor with an index for its input and one for its output.+name :: forall {k} (a :: k) b. (Hypergraph k) => a ~> b -> Tensor '[a, b]+name f = Str ((obj @a ** f) . cup @a) \\ f++-- | Matrix multiplication at the type 'EinsumType' computes, which is checked by compiling it.+matMulE :: EinsumType "ij,jk" '[ '[M2, M3], '[M3, M2]]+matMulE = einsum @"ij,jk"++-- `\_ -> unit` binds a summed index that is not used, which is what is tested.+{- HLINT ignore test "Use const" -}+test :: TestTree+test =+  testGroup+    "SMC"+    [ testGroup+        "FinRel"+        [ testProperty "matrix multiplication is composition (2, 3, 4)" $ do+            f <- genNamed @(F2 ~> F3) "f"+            g <- genNamed @(F3 ~> F4) "g"+            check "differs from g . f" (matMulT f g == g . f)+        , testProperty "the trace is the cap after the cup (3)" $ do+            f <- genNamed @(F3 ~> F3) "f"+            check "differs" (traceIdxT f == cap @F3 . (f ** obj @F3) . cup @F3)+        , testProperty "the entrywise product is mappend after the two after comult (2, 3)" $ do+            f <- genNamed @(F2 ~> F3) "f"+            g <- genNamed @(F2 ~> F3) "g"+            check "differs" (hadamardT f g == mappend @F3 . (f ** g) . comult @F2)+        , testProperty "an index used twice from a sum is the cup (3)" $+            check "differs from cup" (toSMC @I (\() -> sumOver @(F F3) \j -> j SMC.** j) == cup @F3)+        , testProperty "an unused summed index is the counit after the unit (3)" $+            check "differs" (toSMC @I (\() -> sumOver @(F F3) \_ -> unit) == counit @F3 . mempty @F3)+        , testProperty "einsum ij,jk->ik is composition (2, 3, 4)" $ do+            f <- genNamed @(F2 ~> F3) "f"+            g <- genNamed @(F3 ~> F4) "g"+            check "differs from g . f" (unStr (einsum @"ij,jk->ik" (name f) (name g)) == unStr (name (g . f)))+        ]+    , testGroup+        "Mat Int"+        [ testProperty "matrix multiplication is composition (2, 3, 2)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            g <- genNamed @(M3 ~> M2) "g"+            check "differs from g . f" (unMat (matMulT f g) == unMat (g . f))+        , testProperty "the trace is the sum of the diagonal (3)" $ do+            f <- genNamed @(M3 ~> M3) "f"+            check "differs from cap . (f ** id) . cup" (unMat (traceIdxT f) == unMat (cap @M3 . (f ** obj @M3) . cup @M3))+        , testProperty "the trace of the identity is the dimension (3)" $+            check "not 3" (unMat (traceIdxT (obj @M3)) == ((3 ::: VNil) ::: VNil))+        , testProperty "the transpose is the dagger (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            check "differs from dagger" (unMat (transposeT f) == unMat (dagger f))+        , testProperty "the entrywise product is mappend after the two after comult (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            g <- genNamed @(M2 ~> M3) "g"+            check "differs" (unMat (hadamardT f g) == unMat (mappend @M3 . (f ** g) . comult @M2))+        ]+    , testGroup+        "einsum on Mat Int"+        [ testProperty "ij,jk->ik is composition (2, 3, 2)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            g <- genNamed @(M3 ~> M2) "g"+            check "differs from g . f" (unMat (unStr (einsum @"ij,jk->ik" (name f) (name g))) == unMat (unStr (name (g . f))))+        , testProperty "ij->ji is the dagger (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            check "differs from dagger" (unMat (unStr (einsum @"ij->ji" (name f))) == unMat (unStr (name (dagger f))))+        , testProperty "ii-> is the trace (3)" $ do+            f <- genNamed @(M3 ~> M3) "f"+            check "differs" (unMat (unStr (einsum @"ii->" (name f))) == unMat (traceIdxT f))+        , testProperty "ij-> is the sum of the entries (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            check "differs" (unMat (unStr (einsum @"ij->" (name f))) == unMat (counit @M3 . f . mempty @M2))+        , testProperty "ij,ij->ij is the entrywise product (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            g <- genNamed @(M2 ~> M3) "g"+            check "differs" (unMat (unStr (einsum @"ij,ij->ij" (name f) (name g))) == unMat (unStr (name (hadamardT f g))))+        , testProperty "without ->, ij,jk is composition, at the type EinsumType computes (2, 3, 2)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            g <- genNamed @(M3 ~> M2) "g"+            check "differs" (unMat (unStr (matMulE (name f) (name g))) == unMat (unStr (name (g . f))))+        , testProperty "without ->, ji is the dagger, its output being sorted (2, 3)" $ do+            f <- genNamed @(M2 ~> M3) "f"+            check "differs from dagger" (unMat (unStr (einsum @"ji" (name f))) == unMat (unStr (name (dagger f))))+        , testProperty "without ->, ii is the trace (3)" $ do+            f <- genNamed @(M3 ~> M3) "f"+            check "differs" (unMat (unStr (einsum @"ii" (name f))) == unMat (traceIdxT f))+        , testProperty "i->ii puts a vector on the diagonal (3)" $ do+            u <- genNamed @(Unit ~> M3) "u"+            check "differs from comult" (unMat (unStr (einsum @"i->ii" (Str u :: Tensor '[M3]))) == unMat (comult @M3 . u))+        , testProperty "i,j->ij is the tensor of the two (2, 3)" $ do+            u <- genNamed @(Unit ~> M2) "u"+            v <- genNamed @(Unit ~> M3) "v"+            check+              "differs"+              (unMat (unStr (einsum @"i,j->ij" (Str u :: Tensor '[M2]) (Str v :: Tensor '[M3]))) == unMat ((u ** v) . leftUnitorInv))+        , testProperty "ijk->kij moves the last index to the front (2, 3)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M3, M2]) "t"+            check "differs from the reference" $+              entries (unStr (einsum @"ijk->kij" (Str t :: Tensor '[M2, M3, M2])))+                == reference [("ijk", [2, 3, 2], entries t)] "kij"+        , testProperty "ijk,jl->ljk contracts and reorders (2, 3)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M3, M2]) "t"+            u <- genNamed @(Unit ~> Fold '[M3, M2]) "u"+            check "differs from the reference" $+              entries (unStr (einsum @"ijk,jl->ljk" (Str t :: Tensor '[M2, M3, M2]) (Str u :: Tensor '[M3, M2])))+                == reference [("ijk", [2, 3, 2], entries t), ("jl", [3, 2], entries u)] "ljk"+        , testProperty "ij,jk,ki-> is the trace of the product of three (2)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M2]) "t"+            u <- genNamed @(Unit ~> Fold '[M2, M2]) "u"+            v <- genNamed @(Unit ~> Fold '[M2, M2]) "v"+            check "differs from the reference" $+              entries+                (unStr (einsum @"ij,jk,ki->" (Str t :: Tensor '[M2, M2]) (Str u :: Tensor '[M2, M2]) (Str v :: Tensor '[M2, M2])))+                == reference [("ij", [2, 2], entries t), ("jk", [2, 2], entries u), ("ki", [2, 2], entries v)] ""+        , testProperty "kl,jkk,ijx,li->li: a ring, a diagonal, an index of one tensor, three-legged spiders (2, 3)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M3]) "t"+            u <- genNamed @(Unit ~> Fold '[M3, M2, M2]) "u"+            v <- genNamed @(Unit ~> Fold '[M2, M3, M3]) "v"+            w <- genNamed @(Unit ~> Fold '[M3, M2]) "w"+            check "differs from the reference" $+              entries+                ( unStr+                    ( einsum @"kl,jkk,ijx,li->li"+                        (Str t :: Tensor '[M2, M3])+                        (Str u :: Tensor '[M3, M2, M2])+                        (Str v :: Tensor '[M2, M3, M3])+                        (Str w :: Tensor '[M3, M2])+                    )+                )+                == reference+                  [ ("kl", [2, 3], entries t)+                  , ("jkk", [3, 2, 2], entries u)+                  , ("ijx", [2, 3, 3], entries v)+                  , ("li", [3, 2], entries w)+                  ]+                  "li"+        , testProperty "ab,bc,xy,yz,cz->ax: two pairs contracted apart, then joined (2, 3)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M3]) "t"+            u <- genNamed @(Unit ~> Fold '[M3, M2]) "u"+            v <- genNamed @(Unit ~> Fold '[M3, M2]) "v"+            w <- genNamed @(Unit ~> Fold '[M2, M3]) "w"+            x <- genNamed @(Unit ~> Fold '[M2, M3]) "x"+            check "differs from the reference" $+              entries+                ( unStr+                    ( einsum @"ab,bc,xy,yz,cz->ax"+                        (Str t :: Tensor '[M2, M3])+                        (Str u :: Tensor '[M3, M2])+                        (Str v :: Tensor '[M3, M2])+                        (Str w :: Tensor '[M2, M3])+                        (Str x :: Tensor '[M2, M3])+                    )+                )+                == reference+                  [ ("ab", [2, 3], entries t)+                  , ("bc", [3, 2], entries u)+                  , ("xy", [3, 2], entries v)+                  , ("yz", [2, 3], entries w)+                  , ("cz", [2, 3], entries x)+                  ]+                  "ax"+        , testPropertyWith fewer "ij,jk,kl,lm->im is the product of four (3)" $ do+            t <- genNamed @(Unit ~> Fold '[M3, M3]) "t"+            u <- genNamed @(Unit ~> Fold '[M3, M3]) "u"+            v <- genNamed @(Unit ~> Fold '[M3, M3]) "v"+            w <- genNamed @(Unit ~> Fold '[M3, M3]) "w"+            check "differs from the reference" $+              entries+                ( unStr+                    ( einsum @"ij,jk,kl,lm->im"+                        (Str t :: Tensor '[M3, M3])+                        (Str u :: Tensor '[M3, M3])+                        (Str v :: Tensor '[M3, M3])+                        (Str w :: Tensor '[M3, M3])+                    )+                )+                == reference+                  [("ij", [3, 3], entries t), ("jk", [3, 3], entries u), ("kl", [3, 3], entries v), ("lm", [3, 3], entries w)]+                  "im"+        , testProperty "ijk->ijki copies an index to a later position (2, 3)" $ do+            t <- genNamed @(Unit ~> Fold '[M2, M3, M2]) "t"+            check "differs from the reference" $+              entries (unStr (einsum @"ijk->ijki" (Str t :: Tensor '[M2, M3, M2])))+                == reference [("ijk", [2, 3, 2], entries t)] "ijki"+        ]+    ]+  where+    -- the product of all four would have 6561 entries; contracting pairwise keeps it at 81+    fewer = defaultTestOptions{overrideNumTests = Just 5}++-- | The entries of a state of Mat, the first index varying fastest.+entries :: Mat (a :: MatK Int) b -> [Int]+entries (Mat m) = concatMap toList m++-- | Einstein summation on tensors given by their letters, the sizes of their indices and their+-- entries, the first index varying fastest, written out as sums of products.+reference :: [(String, [Int], [Int])] -> String -> [Int]+reference ins out =+  [ if consistent+      then sum [product [at dims vs (pick ls) | (ls, dims, vs) <- ins] | rest <- tuples restDims, let pick = assign rest]+      else 0+  | o <- tuples (fmap size out)+  , let fixed = M.fromListWith (\a b -> if a == b then a else -1) (zip out o)+        consistent = (-1) `notElem` M.elems fixed+        assign rest ls = [M.findWithDefault (M.fromList (zip summed rest) M.! l) l fixed | l <- ls]+  ]+  where+    size l = sum (take 1 [d | (ls, dims, _) <- ins, (l', d) <- zip ls dims, l' == l])+    summed = nubOrd [l | (ls, _, _) <- ins, l <- ls, l `notElem` out]+    restDims = fmap size summed+    -- every index tuple, the first index varying fastest+    tuples ds = fmap reverse (traverse (\d -> [0 .. d - 1]) (reverse ds))+    at dims vs is = vs !! foldr (\(d, i) acc -> i + d * acc) 0 (zip dims is)
test/Props/Sheaf.hs view
@@ -93,7 +93,7 @@ import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..)) import Proarrow.Profunctor.Instance.Yoneda (Yo) import Proarrow.Testing-  ( Some (..)+  ( SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)
test/Props/Sheaf/Collage.hs view
@@ -45,7 +45,7 @@ import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor) import Proarrow.Profunctor.Instance.Yoneda (Yo) import Proarrow.Testing-  ( Some (..)+  ( SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)@@ -187,7 +187,10 @@   genSome =     genSomeList       "Copresheaf Patches"-      [Some @(Yo '() (OP (L '(FLS, FLS)))), Some @(Yo '() (OP (R '()))), Some @(TerminalProfunctor :: Copresheaf Patches)]+      [ Some @(Yo '() (OP (L '(FLS, FLS))))+      , Some @(Yo '() (OP (R '())))+      , Some @(TerminalProfunctor :: Copresheaf Patches)+      ]  -- | Restriction of copresheaves along 'Inc', written as a right Kan extension. type RanInc :: Copresheaf Patches -> Copresheaf (BOOL, BOOL)
test/Props/Span.hs view
@@ -15,7 +15,7 @@ import Data.List (sort) import Proarrow.Testing   ( GenTotal (..)-  , Some (..)+  , SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)
test/Props/Svg.hs view
@@ -11,7 +11,7 @@ import Test.Falsify.Generator (elem) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty)-import Prelude hiding (Monoid, elem, id, (.))+import Prelude hiding (Monoid, elem, id, mappend, mempty, (.))  import Proarrow.Category.Monoidal (Monoidal, SymMonoidal, SymMonoidalStructures, withOb2) import Proarrow.Category.Monoidal.Closed (ClosedStructures)@@ -21,24 +21,34 @@ import Proarrow.Category.Monoidal.Hypergraph (FrobeniusStructures) import Proarrow.Category.Monoidal.StarAutonomous (StarAutonomousStructures) import Proarrow.Category.Monoidal.Strength (TracedStructures)-import Proarrow.Category.Monoidal.Strictified (IsList (..))+import Proarrow.Category.Monoidal.Strictified (withIsListOf) import Proarrow.Core (CategoryOf (..), Promonad (..), UN)-import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid, Monoid, Supplies)+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..), Supplies)+import Proarrow.Object (withListOf) import Proarrow.Tools.Diagrams.Svg-  ( KnownWire+  ( Diagram (..)+  , KnownWire   , Options (..)   , SVG (..)   , Svg (..)   , W (..)+  , bends   , defaultOptions+  , hideUnits+  , kindsIn+  , kindsOut   , lawSvgsWith   , node+  , render+  , renderWith+  , slide   , wires   , withIsListErase   )+import Proarrow.Tools.SMC.Examples (combineDualT, hadamardT, loopCC, matMulT, rotT, snakeT, swapT, traceIdxT)  import Proarrow.Testing-  ( Some (..)+  ( SomeOf (..)   , Testable (..)   , TestableProfunctor   , TestableType (..)@@ -68,11 +78,19 @@     , testCompactClosed_ @SVG     , testTraced_ @SVG     , testProperty "every law draws as an equation" $ do-        let everything = Options{explicitIdentities = True, explicitCoherence = True, explicitSwaps = True, fixedSpiders = False}+        let everything =+              Options+                { explicitIdentities = True+                , explicitCoherence = True+                , explicitSwaps = True+                , fixedSpiders = False+                , bendSpiders = True+                , slidePoints = True+                }             structures :: [[(String, String)]]             structures =               [ drawn-              | o <- [defaultOptions, everything]+              | o <- [defaultOptions, everything, defaultOptions{bendSpiders = True, slidePoints = True}]               , drawn <-                   [ lawSvgsWith @'[CategoryOf] o                   , lawSvgsWith @'[Monoidal] o@@ -95,26 +113,62 @@           -- reads every character of the drawing, so its layout is computed in full           forM_ drawn \(name, d) ->             check (name ++ " drew malformed markup") (count '<' d > 0 && count '<' d == count '>' d)+    , testProperty "with bent spiders, the trace in index notation draws no points" $ do+        let t = traceIdxT @(S '[Wire "A"]) (node "f")+        check "the default draws no points" (points (render t) == 4)+        check "points are left" (points (renderWith defaultOptions{bendSpiders = True} t) == 0)+    , testProperty "slid and bent, matrix multiplication in index notation draws no points" $ do+        let m = matMulT @(S '[Wire "A"]) @(S '[Wire "B"]) @(S '[Wire "A"]) (node "f") (node "g")+        check "the default draws no points" (points (render m) == 8)+        check "points are left" (points (renderWith defaultOptions{bendSpiders = True, slidePoints = True} m) == 0)+    , testProperty "sliding points and bending spiders keep every stack's wires matching, with or without unit wires" $+        forM_+          @[]+          [ tree (traceIdxT @(S '[Wire "A"]) (node "f"))+          , tree (hadamardT @(S '[Wire "A"]) @(S '[Wire "B"]) (node "f") (node "g"))+          , tree (matMulT @(S '[Wire "A"]) @(S '[Wire "B"]) @(S '[Wire "A"]) (node "f") (node "g"))+          , tree (loopCC @(S '[Wire "A"]) @(S '[Wire "B"]) @(S '[Wire "A"]) (node "h"))+          , tree (snakeT @(S '[Wire "A"]))+          , tree (combineDualT @(S '[Wire "A"]) @(S '[Wire "B"]))+          , tree (swapT @(S '[Wire "A"]) @(S '[Wire "B"]))+          , tree (rotT @(S '[Wire "A"]) @(S '[Wire "B"]) @(S '[Wire "A"]))+          ]+          \d -> do+            -- with the unit wires shown, as with explicit coherence, and with them hidden+            forM_ @[] [d, hideUnits d] \h -> do+              check "a stack's wires do not match before" (matching h)+              forM_ @[] [slide h, bends h, bends (slide h)] \d' -> do+                check "a stack's wires do not match" (matching d')+                check "the boundary changed" (kindsIn d' == kindsIn h && kindsOut d' == kindsOut h)+    , testProperty "with bent spiders, a merge and a discard on two wires draw a cap, and a unit and a copy a cup" $+        forM_ @[] [defaultOptions{bendSpiders = True}, defaultOptions{bendSpiders = True, slidePoints = True}] \o -> do+          check "the cap has points" (points (renderWith o (counit @(S '[Wire "A", Wire "B"]) . mappend)) == 0)+          check "the cup has points" (points (renderWith o (comult . mempty @(S '[Wire "A", Wire "B"]))) == 0)+    , testProperty "with bent spiders, the entrywise product keeps only its copy points" $ do+        let h = hadamardT @(S '[Wire "A"]) @(S '[Wire "B"]) (node "f") (node "g")+        check "the default draws other points" (points (render h) == 8)+        check "other points are left" (points (renderWith defaultOptions{bendSpiders = True} h) == 2)     ]---- | A wire of the palette objects are drawn from.-data SomeWire where-  SomeWire :: forall (w :: W). (KnownWire w) => SomeWire+  where+    -- every point is drawn as one circle+    points = length . filter ("<circle" `List.isPrefixOf`) . List.tails+    tree :: Svg a b -> Diagram+    tree (Svg _ d) = d+    -- the wires coming out of every step of a stack are the ones going into the next+    matching = \case+      Seq a b -> kindsOut a == kindsIn b && matching a && matching b+      Beside a b -> matching a && matching b+      Trace _ d -> matching d+      _ -> True  -- | Up to two wires, each a plain wire, a dual wire or the unit wire, so that the laws are checked -- where the meaning leaves wires out or forgets that they are dual. instance Testable SVG where   genSome = do     num <- elem [0 .. 2]-    ws <- replicateM num (elem [SomeWire @(Wire "A"), SomeWire @(Wire "B"), SomeWire @(Co "A"), SomeWire @I])-    pure (foldWires ws)+    ws <- replicateM num (elem [Some @(Wire "A"), Some @(Wire "B"), Some @(Co "A"), Some @I])+    pure (withListOf @KnownWire ws \ @ws l -> withIsListOf l (Some @(S ws)))   showOb @ws = List.intercalate "," $ map fst $ wires @(UN S ws)--foldWires :: [SomeWire] -> Some SVG-foldWires [] = Some @(S '[])-foldWires [SomeWire @w] = Some @(S '[w])-foldWires (SomeWire @w : rest) = case foldWires rest of-  Some @(S ws) -> withIsList2 @'[w] @ws (Some @(S (w ': ws)))  instance (Ob a, Ob b) => TestingEqShow (Svg a b) where   eqP (Svg @as @bs l _) (Svg r _) = withIsListErase @as $ withIsListErase @bs $ eqP l r
+ test/Props/TensorNetwork.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Tensor networks with integer entries, compared by their entries.+module Props.TensorNetwork (test) where++import Data.Complex (Complex (..))+import Data.Vector.Storable qualified as SV+import GHC.TypeNats (KnownNat)+import Test.Falsify (Property)+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (TestOptions (..), testProperty, testPropertyWith)+import Prelude hiding (elem, id, (**), (.))++import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))+import Proarrow.Category.Instance.TensorNetwork+  ( Scalar+  , TNET (..)+  , TensorNetwork+  , dimsOf+  , entries+  , fromEntries+  , fromVector+  , toVector+  )+import Proarrow.Category.Monoidal.Hypergraph (Sized (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), UN)+import Proarrow.Object (KnownListOf, type (++))+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , expect+  , genNamed+  , genSomeDef+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Proarrow.Tools.Einsum (einsum)+import Props.Mat ()+import Props.SMC (name)++type T2 :: TNET Int+type T2 = TN '[2]++type T3 :: TNET Int+type T3 = TN '[3]++test :: TestTree+test =+  testGroup+    "Tensor networks"+    [ testCategory @(TNET Int)+    , testDagger @(TNET Int)+    , testTerminalObject @(TNET Int)+    , testInitialObject @(TNET Int)+    , testBinaryProducts_ @(TNET Int)+    , testBinaryCoproducts_ @(TNET Int)+    , testDistributive_ @(TNET Int)+    , testTraced_ @(TNET Int)+    , testMonoidal_ @(TNET Int)+    , testSymMonoidal_ @(TNET Int)+    , testClosed_ @(TNET Int)+    , testDialogue_ @(TNET Int)+    , testStarAutonomous_ @(TNET Int)+    , testIsoMix_ @(TNET Int)+    , testCompactClosed_ @(TNET Int)+    , testCopyDiscard_ @(TNET Int)+    , testHypergraph_ @(TNET Int)+    , testGroup+        "entries"+        [ testProperty "fromEntries then entries is the entries (2, 3)" $ do+            f <- genNamed @(T2 ~> T3) "f"+            expect "entries" (entries f) (entries (fromEntries @'[2] @'[3] (entries f)))+        , testProperty "fromVector then toVector is the vector (2, 3)" $ do+            f <- genNamed @(T2 ~> T3) "f"+            expect "entries" (toVector f) (toVector (fromVector @'[2] @'[3] (toVector f)))+        , testProperty "the dagger conjugates complex entries" $+            expect+              "entries"+              (SV.fromList [1 :+ (-2), 3 :+ 4])+              (toVector (dagger (fromVector @'[1] @'[2] (SV.fromList [1 :+ 2, 3 :+ (-4)] :: SV.Vector (Complex Double)))))+        ]+    , testGroup+        "einsum"+        [ testProperty "ij,jk is the name of the composite (2, 3)" $ do+            f <- genNamed @(T2 ~> T3) "f"+            g <- genNamed @(T3 ~> T2) "g"+            expect "entries" (entries (unStr (name (g . f)))) (entries (unStr (einsum @"ij,jk" (name f) (name g))))+        , testProperty "ij,ij,ij-> is the sum of the entrywise product (2, 3)" $ do+            f <- genNamed @(T2 ~> T3) "f"+            g <- genNamed @(T2 ~> T3) "g"+            h <- genNamed @(T2 ~> T3) "h"+            let flat = SV.toList . toVector+            expect+              "entries"+              [[sum (zipWith3 (\x y z -> x * y * z) (flat f) (flat g) (flat h))]]+              (entries (unStr (einsum @"ij,ij,ij->" (name f) (name g) (name h))))+        , testProperty "ij,jk,kl,lm->im is the product of four (3)" (productOfFour @'[3])+        , testPropertyWith fewer "ij,jk,kl,lm->im is the product of four (32)" (productOfFour @'[32])+        , testPropertyWith fewer "kl,jkk,ijx,li->li at Double is the same as at Int (16, 24)" $ do+            v <- genNamed @(TN '[] ~> (TN '[16, 24] :: TNET Int)) "v"+            u <- genNamed @(TN '[] ~> (TN '[24, 16, 16] :: TNET Int)) "u"+            t <- genNamed @(TN '[] ~> (TN '[16, 24, 24] :: TNET Int)) "t"+            w <- genNamed @(TN '[] ~> (TN '[24, 16] :: TNET Int)) "w"+            expect "entries" (asDoubles (ring v u t w)) (entries (ring (double v) (double u) (double t) (double w)))+        ]+    ]+  where+    -- a product of all four would have 32^8 entries; each pairwise contraction costs about 32^3+    fewer = defaultTestOptions{overrideNumTests = Just 5}++-- | The same arrow with its entries as 'Double's, which are contracted with 'gemm' where there is+-- one.+double+  :: (KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => TensorNetwork (TN as :: TNET Int) (TN bs) -> TensorNetwork (TN as :: TNET Double) (TN bs)+double f = fromVector (SV.map fromIntegral (toVector f))++-- | The entries of an arrow as 'Double's.+asDoubles :: TensorNetwork (a :: TNET Int) b -> [[Double]]+asDoubles = fmap (fmap fromIntegral) . entries++-- | The einsum of a chain of four matrices is their product, also at 'Double'.+productOfFour :: forall ns. (KnownListOf KnownNat ns) => Property ()+productOfFour = do+  a <- genNamed @(TN ns ~> (TN ns :: TNET Int)) "a"+  b <- genNamed @(TN ns ~> (TN ns :: TNET Int)) "b"+  c <- genNamed @(TN ns ~> (TN ns :: TNET Int)) "c"+  d <- genNamed @(TN ns ~> (TN ns :: TNET Int)) "d"+  let product4 = unStr (name (d . c . b . a))+  expect "entries" (entries product4) (entries (chain4 a b c d))+  expect "entries at Double" (asDoubles product4) (entries (chain4 (double a) (double b) (double c) (double d)))++-- | The einsum of a chain of four matrices.+chain4+  :: forall e ns+   . (Scalar e, KnownListOf KnownNat ns)+  => TensorNetwork (TN ns :: TNET e) (TN ns)+  -> TensorNetwork (TN ns :: TNET e) (TN ns)+  -> TensorNetwork (TN ns :: TNET e) (TN ns)+  -> TensorNetwork (TN ns :: TNET e) (TN ns)+  -> TensorNetwork (TN '[] :: TNET e) (TN (ns ++ ns))+chain4 a b c d = unStr (einsum @"ij,jk,kl,lm->im" (name a) (name b) (name c) (name d))++-- | The ring of the wiki's einsum page, with the sizes 16 and 24.+ring+  :: (Scalar e)+  => TensorNetwork (TN '[] :: TNET e) (TN '[16, 24])+  -> TensorNetwork (TN '[] :: TNET e) (TN '[24, 16, 16])+  -> TensorNetwork (TN '[] :: TNET e) (TN '[16, 24, 24])+  -> TensorNetwork (TN '[] :: TNET e) (TN '[24, 16])+  -> TensorNetwork (TN '[] :: TNET e) (TN '[24, 16])+ring v u t w =+  unStr+    ( einsum @"kl,jkk,ijx,li->li"+        (Str @'[] @'[TN '[16], TN '[24]] v)+        (Str @'[] @'[TN '[24], TN '[16], TN '[16]] u)+        (Str @'[] @'[TN '[16], TN '[24], TN '[24]] t)+        (Str @'[] @'[TN '[24], TN '[16]] w)+    )++instance Testable (TNET Int) where+  showOb @a = show (dimsOf @(UN TN a))+  genSome = genSomeDef @'[TN '[], TN '[2], TN '[3], TN '[2, 1]]++instance (Ob (a :: TNET Int), Ob b) => TestableType (TensorNetwork a b) where+  gen = GenNonEmpty (fromVector <$> SV.replicateM (sizeOf @_ @a * sizeOf @_ @b) (liftA2 (*) (elem [1, -1]) (elem [0 .. 9])))++instance (Ob (a :: TNET Int), Ob b) => TestingEqShow (TensorNetwork a b) where+  eqP l r = pure (toVector l == toVector r)+  showP = show . entries++instance TestableProfunctor (TensorNetwork :: CAT (TNET Int))
testing/Proarrow/Testing.hs view
@@ -33,7 +33,8 @@   , withTestObDualDef      -- * Objects-  , Some (..)+  , Some+  , SomeOf (..)   , mapSome   , genOb   , genObSmall@@ -42,7 +43,7 @@   , genSomeDef   , genSomeFinite   , genSomeList-  , MkSomeList (..)+  , mkSomeList      -- * Profunctor elements   , SomeProfunctorElt (..)@@ -124,6 +125,7 @@ import Proarrow.Functor qualified as Rep import Proarrow.Limit.BinaryProduct (PROD (..), Prod (..)) import Proarrow.Limit.BinaryProduct qualified as BinaryProduct+import Proarrow.Object (KnownListOf (..), SomeOf (..), someOfList) import Proarrow.Profunctor.Corepresentable (type (%%)) import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar)@@ -476,18 +478,17 @@ -- | @'TestOb'@ is closed under a corepresentable profunctor. type WithTestObCorep k p = forall (a :: k) r. (TestOb a) => ((TestOb (p %% a)) => r) -> r -data Some k where-  Some :: forall {k} a. (TestOb (a :: k)) => Some k+-- | A testable object of @k@.+type Some :: Type -> Type+type Some k = SomeOf (TestOb' :: OB k)  mapSome :: forall {j} {k}. forall (f :: j -> k) -> (forall a. (TestOb a) => TestOb' (f a)) => Some j -> Some k mapSome f (Some @a) = Some @(f a) -class MkSomeList (as :: [k]) where-  mkSomeList :: [Some k]-instance MkSomeList '[] where-  mkSomeList = []-instance (TestOb (a :: k), MkSomeList as) => MkSomeList (a ': as) where-  mkSomeList = Some @a : mkSomeList @k @as+-- | The objects of a type-level list.+mkSomeList :: forall {k} (as :: [k]). (KnownListOf TestOb' as) => [Some k]+mkSomeList = someOfList (listOf @TestOb' @as)+ instance (Testable k) => Show (Some k) where   show (Some @a) = showOb @k @a @@ -501,8 +502,8 @@ someElemWith _ [] = discard someElemWith f (x : xs) = genWith (Just . f) (elem (x :| xs)) -genSomeDef :: forall {k} (obs :: [k]). (Testable k, MkSomeList obs) => Gen (Some k)-genSomeDef = genSomeList "the palette is empty" (mkSomeList @k @obs)+genSomeDef :: forall {k} (obs :: [k]). (Testable k, KnownListOf TestOb' obs) => Gen (Some k)+genSomeDef = genSomeList "the palette is empty" (mkSomeList @obs)  -- | The palette of a category that already knows its own objects: @'Proarrow.Category.Enriched.Thin.Objects' k@ -- is the list 'genSomeDef' would otherwise be given by hand, and writing it twice lets the two
testing/Proarrow/Testing/Laws/Run.hs view
@@ -94,7 +94,8 @@ import Proarrow.Profunctor.Representable (Representable (..), withObRep) import Proarrow.Promonad qualified as Promonad import Proarrow.Testing-  ( Some (..)+  ( Some+  , SomeOf (..)   , SomeProfunctorElt (..)   , TestObIsOb   , Testable (..)