packages feed

proarrow 0.3.0.0 → 0.4.0.0

raw patch · 72 files changed

+7925/−1096 lines, 72 filesdep +WAVEdep +Yampadep +asyncnew-component:exe:smc-audio

Dependencies added: WAVE, Yampa, async, directory, filepath, process, temporary

Files

CHANGELOG.md view
@@ -1,5 +1,62 @@ # Revision history for proarrow +## Unreleased++## 0.4.0.0 -- 2026-10-23++* `Proarrow.Tools.SMC`:+  * `Proarrow.Tools.CCC` now uses SMC syntax, contexts, patterns and binders in `PROD k`.+  * `TermP p`, terms whose computations are arrows of a promonad `p`, compiled by `proc`;+    `Term` is `TermP (~>)`.+  * `toSMC1` and `toCCC1` infer embedded input and output objects from the surrounding morphism type.+  * Tuple patterns, binds and tuples of five and six; `liftF` applies a morphism to a term or+    tuple of terms and embeds its result by `F`, allowing the result object to be inferred.+    Its infix form `(-<)` and `returnA`, an alias for the identity morphism, mirror+    Haskell's arrow notation. All three are also available in `Proarrow.Tools.CCC`.+  * Arrow application and tuple construction reuse variables across binds without explicit depth casts;+    `TupleDepth` is removed.+  * `ifThenElse`, an alias for `caseOf`, supports sum elimination with `RebindableSyntax`+    in SMC and CCC: `if x then \l -> ... else \r -> ...`.+  * `(!)` also accepts embedded function objects, including results of `(-<)`, in SMC and CCC.+  * Computation binds accept embedded dual objects as continuation results, allowing `(-<)` there.+  * Scalar multiplication accepts `F Unit`, including results of `(-<)`.+  * A Yampa feedback-echo example and `smc-audio` executable render dry and echoed WAV files+    and a string diagram from the same SMC network. The GitHub Pages documentation build+    includes the audio files for listening from the wiki.+* `Proarrow.Profunctor.Instance.Star`: `Costrong Tensor (Star (Prelude m))` for `MonadFix m`,+  supporting feedback through SMC's `loop` and recursive `do`.+* Decorated cospans, including open hypergraphs, now support traced SMC notation.+* `Proarrow.Category.Instance.OpenHypergraph`: graph substitution with optional wire-sort expansion.+  `readBack` and `simplify` now take a `Wiring`, supporting symmetric monoidal, copy/discard+  and Frobenius structure, with optional tracing via `tracedWith`.+  `frobeniusWith` replaces `readBackWith` and `simplifyWith`; `simplifyHypergraph` provides+  total read-back for primitive graphs in hypergraph targets.+  `prim0` through `prim3` lift ordinary arrows as boxes with zero to three inputs and one output.+* `OpenHypergraph` read-back reduces swap cost, including within contraction trees; `layered` exposes parallel tensor layers.+* An SMC build pipeline demonstrates automatic parallel scheduling, with executable builds and measured timelines.+* `Proarrow.Tools.ContractionOrder`: `planContraction`, the order to contract a network of factors+  in, the cheaper of numpy's greedy order and a min-fill elimination order (`minFillOrder`). The+  read-back of open hypergraphs, and with it einsum, and tensor networks contract along it.+  `Proarrow.Category.Instance.OpenHypergraph`: `simplifyFlat`, which bends every box into a state+  first, so the whole network is contracted in that order.+* `Proarrow.Category.Instance.TensorNetwork`: `matMul`, a product of matrices given as vectors,+  through BLAS when the `blas` flag is on; the dagger copies no entries, and complex ones are+  conjugated once, when first needed.+* `Proarrow.Tools.Optic`: compile SMC programs of optics to forward/backward computations+  through graph substitution, requiring only symmetric monoidal structure in the target.+* `Proarrow.Optic.Action`: `runMonoidalOptic` connects a tensor-action optic's forward and+  backward passes into one computation.+* `Proarrow.Category.Instance.Circuit` and `Simulator`: typed digital circuits with clocked+  simulation and Verilog generation, plus an SMC counter demo.+* Wiki walkthroughs of the digital counter and parallel build examples, linked from the README.+* `Proarrow.Category.Instance.Diff`: `DIFF`, differentiable maps with their reverse derivatives+* SVG diagrams declare UTF-8 encoding for standalone viewers.+* `Proarrow.Squares`: orient data flow rightward, add matching horizontal/vertical helpers and pointwise evaluation,+  and explore optics as square programs.+* Applicative `Star (Prelude f)` effects now support `Prostrong TravFl`.+* `Proarrow.Object`: `withKnownAppend` and `withKnownAssoc`, the `KnownListOf` evidence of appended lists.+* `Proarrow.Testing`: `TestableType` and `TestingEqShow` for `Corep`.+ ## 0.3.0.0 -- 2026-10-10  * `Proarrow.Tools.Einsum`: `einsum @"ij,jk->ik" a b` on tensors in hypergraph categories.
README.md view
@@ -4,6 +4,31 @@  A Haskell library for doing category theory with a central role for profunctors. +## Guided tours++The [wiki](https://github.com/sjoerdvisscher/proarrow/wiki) explains the ideas through worked examples+and string diagrams. Choose a starting point:++- [Einsum and hypergraph categories](https://github.com/sjoerdvisscher/proarrow/wiki/Einsum-and-hypergraph-categories):+  start with familiar matrix operations, then see how the same notation describes relations,+  string diagrams, and tensor networks, and why contraction order matters.+- [Programming with monoidal categories](https://github.com/sjoerdvisscher/proarrow/wiki/Programming-with-monoidal-categories):+  build quantum circuits and audio feedback with `Proarrow.Tools.SMC`, then explore traces,+  functions, copying, and duals.+- [A clocked digital circuit](https://github.com/sjoerdvisscher/proarrow/wiki/A-clocked-digital-circuit):+  follow a four-bit counter from named wires to gates, simulated waveforms, and Verilog.+- [From a build pipeline to a parallel schedule](https://github.com/sjoerdvisscher/proarrow/wiki/From-a-build-pipeline-to-a-parallel-schedule):+  describe a build once, expose independent jobs through graph read-back, and run and measure+  the resulting concurrent schedule.+- [Producers, consumers and sessions](https://github.com/sjoerdvisscher/proarrow/wiki/Producers-consumers-and-sessions):+  compare categorical morphisms, session processes, the μμ̃-calculus, and SMC terms on the same+  examples, then connect them to call by push value.+- [Optics in proarrow](https://github.com/sjoerdvisscher/proarrow/wiki/Optics-in-proarrow):+  for readers familiar with mixed optics, see how witness pairs and their eliminators define+  optic flavors, subtyping, and lawfulness.+- [Law diagrams](https://github.com/sjoerdvisscher/proarrow/wiki/Law-diagrams):+  use the illustrated equations as a reference alongside the laws stated in the code.+ ## Core ideas  ### One category per kind
mkdocs.sh view
@@ -1,3 +1,6 @@+#!/usr/bin/env bash+set -e+ : "${CABAL:=cabal}" : "${HADDOCK:=haddock}" : "${ARG_COMPILER:=}"@@ -5,6 +8,8 @@ # below (GitHub Pages); hackage-docs.sh sets it to ../, Hackage's own package page. : "${USE_CONTENTS:=}" +python3 -m unittest discover -s tools/haddock+ # The optics lattice diagram (Proarrow.Optics) is generated from lattice.dot: #   dot -Tsvg lattice.dot -o lattice.svg rm -rf docs@@ -12,6 +17,11 @@ # copy the optics lattice image next to the module HTML so Haddock's <<lattice.svg>> resolves cp lattice.svg docs/ +# Audio examples accompany the GitHub Pages docs. Hackage uses its own contents page.+if [ -z "$USE_CONTENTS" ]; then+  ${CABAL} run exe:smc-audio ${ARG_COMPILER} -- docs/audio || exit $?+fi+ # 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@@ -29,18 +39,16 @@     ${USE_CONTENTS:+--use-contents=${USE_CONTENTS}}     --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+# The build plan locates the interfaces in this checkout, CI's unpacked packages, or a custom builddir.+python3 tools/haddock/interfaces.py ${ARG_COMPILER}  # 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++# A partial contents page must not be published.+python3 tools/haddock/interfaces.py --check-index  # 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'
proarrow.cabal view
@@ -1,6 +1,6 @@ cabal-version:      3.0 name:               proarrow-version:            0.3.0.0+version:            0.4.0.0 synopsis:           Category theory with a central role for profunctors description:     A library for doing category theory in Haskell with profunctors, rather@@ -30,8 +30,14 @@  extra-source-files:     fix-github-links.py+    tools/haddock/interfaces.py+    tools/haddock/test_interfaces.py     lattice.dot     mkdocs.sh+    tools/smc-audio/README.md+    tools/optic-diagrams/README.md+    tools/optic-diagrams/render.py+    tools/optic-diagrams/template.html  flag blas     description: Contract tensor networks of floating-point numbers with the system's BLAS: Accelerate@@ -48,7 +54,6 @@         DeriveAnyClass         DerivingVia         FunctionalDependencies-        OverloadedLists         NoImplicitPrelude         NoStarIsType         PatternSynonyms@@ -76,6 +81,7 @@         Proarrow.Category.Enriched.Thin         Proarrow.Category.Enriched.Thin.Composition         Proarrow.Category.Instance.Bool+        Proarrow.Category.Instance.Circuit         Proarrow.Category.Instance.Collage         Proarrow.Category.Instance.Constraint         Proarrow.Category.Instance.Coproduct@@ -83,6 +89,7 @@         Proarrow.Category.Instance.DecoratedCospan         Proarrow.Category.Instance.Cps         Proarrow.Category.Instance.Cost+        Proarrow.Category.Instance.Diff         Proarrow.Category.Instance.Discrete         Proarrow.Category.Instance.Duploid         Proarrow.Category.Instance.Fam@@ -105,6 +112,7 @@         Proarrow.Category.Instance.Rel         Proarrow.Category.Instance.Rep         Proarrow.Category.Instance.Simplex+        Proarrow.Category.Instance.Simulator         Proarrow.Category.Instance.Span         Proarrow.Category.Instance.Sub         Proarrow.Category.Instance.TensorNetwork@@ -214,8 +222,10 @@         Proarrow.Promonad.Writer         Proarrow.Squares         Proarrow.Tools.CCC+        Proarrow.Tools.ContractionOrder         Proarrow.Tools.SMC         Proarrow.Tools.Einsum+        Proarrow.Tools.Optic         Proarrow.Tools.SMC.Examples         Proarrow.Tools.SMC.Internal.Additive         Proarrow.Tools.SMC.Internal.Closed@@ -268,35 +278,47 @@ test-suite test     import: extensions     type: exitcode-stdio-1.0-    hs-source-dirs:   test+    hs-source-dirs:   test, tools/smc-audio     main-is:          Main.hs     other-modules:         Examples.Cbpv+        Examples.Circuit+        Examples.CCC         Examples.Cofree         Examples.CustomLaws         Examples.Database         Examples.Einsum         Examples.Free+        Examples.FRP         Examples.FrontDoor         Examples.Readme         Examples.Graph         Examples.UntypedLambdaCalculus         Examples.SimplyTypedLambdaCalculus         Examples.IntComposition+        Examples.Learning         Examples.LinearLogic+        Examples.Probabilistic+        Examples.OpticDiagrams+        Examples.Parallel         Examples.Sessions+        Examples.Squares         Examples.Toffoli         Examples.Vitrea         Props.Bool+        Props.Circuit         Props.DPO         Props.Discrete         Props.Cospan         Props.OpenHypergraph+        Props.OpenHypergraph.Generated         Props.Cps         Props.Cost         Props.Dot         Props.SMC         Props.Svg+        Props.ContractionOrder+        Props.Diff         Props.TensorNetwork         Props.FinHask         Props.FinRel@@ -318,16 +340,38 @@         Props.Sheaf.Collage         Props.Optic.FinRel         Props.Simplex+        Props.Simulator         Props.Span+        Props.Squares         Props.ZX+        SmcAudio     build-depends: proarrow, proarrow:testing     build-depends:+        , async >=2.2 && <2.3         , base >=4.20 && <5         , containers >=0.6 && <0.9+        , directory >=1.3 && <1.4+        , filepath >=1.4 && <1.6+        , process >=1.6 && <1.7         , falsify >=0.4 && <0.5         , fin >= 0.3.2 && <1         , vec >= 0.5.1 && <1         , universe-base >= 1.1.4 && <1.2         , tasty >=1.4 && <1.6         , tasty-falsify >=0.1 && <0.2+        , temporary >=1.3 && <1.4         , vector >= 0.13 && <0.14+        , Yampa >=0.15 && <0.16++executable smc-audio+    import: extensions+    hs-source-dirs: tools/smc-audio+    main-is: Main.hs+    other-modules: SmcAudio+    build-depends:+        base >=4.20 && <5+        , directory >=1.3 && <1.4+        , filepath >=1.4 && <1.6+        , proarrow+        , WAVE >=0.1.6 && <0.2+        , Yampa >=0.15 && <0.16
+ src/Proarrow/Category/Instance/Circuit.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Synchronous digital circuits. The tensor preserves the grouping of bit bundles; copying is+-- fan-out, and tracing connects wires without adding a delay. 'register' delays a bit by one+-- clock cycle. 'prepare' rejects observable combinational cycles before simulation.+--+-- >>> simulate notGate [False, True]+-- Right [True,False]+-- >>> simulate (register False) [True, False, True]+-- Right [False,True,False]+module Proarrow.Category.Instance.Circuit+  ( Wires (..)+  , KnownWires+  , Value+  , Sample+  , PREPARED (..)+  , Prepared+  , Circuit+  , constant+  , notGate+  , andGate+  , orGate+  , xorGate+  , mux+  , register+  , Netlist+  , netlist+  , renderNetlist+  , toDot+  , toVerilog+  , CircuitError (..)+  , Simulator+  , prepare+  , step+  , simulate+  ) where++import Control.Monad ((>=>))+import Data.Graph (SCC (..), stronglyConnComp)+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 Prelude hiding (Functor, fmap, id, (**), (.))+import Prelude qualified as P++import Proarrow.Category.Instance.Simulator (SIMULATOR (..), Simulator (..), runSimulator, step)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Profunctor.Representable (Rep (..))++-- | A bit, no wires, or two bundles. Tensor grouping is retained in the type.+type data Wires = Bit | Empty | Pair Wires Wires++type Shape :: Wires -> Type+data Shape a where+  BitS :: Shape Bit+  EmptyS :: Shape Empty+  PairS :: Shape a -> Shape b -> Shape (Pair a b)++type KnownWires :: Wires -> Constraint+class (Is Sim (Value @ Ready a)) => KnownWires a where+  shape :: Shape a+instance KnownWires Bit where shape = BitS+instance KnownWires Empty where shape = EmptyS+instance (KnownWires a, KnownWires b) => KnownWires (Pair a b) where shape = PairS (shape @a) (shape @b)++-- | Objects of validated circuits, with the same wire shapes as 'Wires'.+type data PREPARED = Ready Wires++-- | Interpret validated circuits as state machines. Bits become 'Bool', the unit becomes @()@,+-- and a tensor becomes a pair, all in the 'SIMULATOR' category.+data family Value :: PREPARED +-> SIMULATOR++-- | The Haskell value for one clock cycle at a wire shape.+type Sample :: Wires -> Type+type Sample a = UN Sim (Value @ Ready a)++type Bundle :: Wires -> Type+data Bundle a where+  BBit :: Int -> Bundle Bit+  BEmpty :: Bundle Empty+  BPair :: Bundle a -> Bundle b -> Bundle (Pair a b)++ports :: Bundle a -> [Int]+ports bundle = go bundle []+  where+    go :: Bundle b -> [Int] -> [Int]+    go (BBit n) rest = n : rest+    go BEmpty rest = rest+    go (BPair a b) rest = go a (go b rest)++inputValues :: Bundle a -> Sample a -> [(Int, Bool)]+inputValues bundle value = go bundle value []+  where+    go :: Bundle b -> Sample b -> [(Int, Bool)] -> [(Int, Bool)]+    go (BBit n) bit rest = (n, bit) : rest+    go BEmpty () rest = rest+    go (BPair a b) (x, y) rest = go a x (go b y rest)++output :: Bundle a -> IM.IntMap Bool -> Sample a+output (BBit n) bs = bs IM.! n+output BEmpty _ = ()+output (BPair a b) bs = (output a bs, output b bs)++-- Each bit has one driver. Aliases connect the placeholders allocated by a trace.+data Driver+  = Input+  | Constant Bool+  | Not Int+  | And Int Int+  | Or Int Int+  | Xor Int Int+  | Mux Int Int Int+  | Register Bool Int+  | Alias Int+  deriving (Show)++inputs :: Driver -> [Int]+inputs Input = []+inputs (Constant _) = []+inputs (Not a) = [a]+inputs (And a b) = [a, b]+inputs (Or a b) = [a, b]+inputs (Xor a b) = [a, b]+inputs (Mux s a b) = [s, a, b]+inputs (Register _ a) = [a]+inputs (Alias a) = [a]++data BuildState = BuildState Int (IM.IntMap Driver)+newtype Build a = Build {runBuild :: BuildState -> (a, BuildState)}+instance P.Functor Build where+  fmap f (Build g) = Build \s -> let (x, s') = g s in (f x, s')+instance Applicative Build where+  pure x = Build (x,)+  f <*> x = do g <- f; g <$> x+instance Monad Build where+  Build f >>= k = Build \s -> let (x, s') = f s in runBuild (k x) s'++fresh :: Driver -> Build Int+fresh d = Build \(BuildState n ds) -> (n, BuildState (n + 1) (IM.insert n d ds))++freshBundle :: Driver -> Shape a -> Build (Bundle a)+freshBundle d BitS = BBit <$> fresh d+freshBundle _ EmptyS = pure BEmpty+freshBundle d (PairS a b) = BPair <$> freshBundle d a <*> freshBundle d b++connect :: Bundle a -> Bundle a -> Build ()+connect (BBit a) (BBit b) = Build \(BuildState n ds) -> ((), BuildState n (IM.insert a (Alias b) ds))+connect BEmpty BEmpty = pure ()+connect (BPair a b) (BPair c d) = connect a c >> connect b d++-- | A typed circuit builder. Constructors are hidden so every output bit has one driver.+type Circuit :: CAT Wires+data Circuit a b where+  Circuit :: (KnownWires a, KnownWires b) => (Bundle a -> Build (Bundle b)) -> Circuit a b++instance CategoryOf Wires where+  type (~>) = Circuit+  type Ob a = KnownWires a+instance Profunctor Circuit where+  dimap = dimapDefault+  r \\ Circuit{} = r+instance Promonad Circuit where+  id = Circuit pure+  Circuit f . Circuit g = Circuit (g >=> f)+instance MonoidalProfunctor Circuit where+  one = Circuit pure+  Circuit f ** Circuit g = Circuit \(BPair a b) -> BPair <$> f a <*> g b+instance Monoidal Wires where+  type Unit = Empty+  type a ** b = Pair a b+  withOb2 r = r+  leftUnitor = Circuit \(BPair BEmpty a) -> pure a+  leftUnitorInv = Circuit \a -> pure (BPair BEmpty a)+  rightUnitor = Circuit \(BPair a BEmpty) -> pure a+  rightUnitorInv = Circuit \a -> pure (BPair a BEmpty)+  associator = Circuit \(BPair (BPair a b) c) -> pure (BPair a (BPair b c))+  associatorInv = Circuit \(BPair a (BPair b c)) -> pure (BPair (BPair a b) c)+instance SymMonoidal Wires where+  swap = Circuit \(BPair a b) -> pure (BPair b a)+instance (KnownWires a) => Comonoid a where+  counit = Circuit \_ -> pure BEmpty+  comult = Circuit \a -> pure (BPair a a)+instance (KnownWires a) => CocommutativeComonoid a+instance CopyDiscard Wires+instance Costrong Tensor Circuit where+  coact @a (Circuit f) = Circuit \x -> do+    feedback <- freshBundle Input (shape @a)+    result <- f (BPair feedback x)+    case result of+      BPair feedback' y -> do+        connect feedback feedback'+        pure y++-- | A constant bit, independent of the clock.+constant :: Bool -> Empty ~> Bit+constant b = Circuit \BEmpty -> BBit <$> fresh (Constant b)++notGate :: Bit ~> Bit+notGate = Circuit \(BBit a) -> BBit <$> fresh (Not a)+andGate :: Bit ** Bit ~> Bit+andGate = Circuit \(BPair (BBit a) (BBit b)) -> BBit <$> fresh (And a b)+orGate :: Bit ** Bit ~> Bit+orGate = Circuit \(BPair (BBit a) (BBit b)) -> BBit <$> fresh (Or a b)+xorGate :: Bit ** Bit ~> Bit+xorGate = Circuit \(BPair (BBit a) (BBit b)) -> BBit <$> fresh (Xor a b)++-- | Select the second input when the first is true, and the third when it is false.+mux :: Bit ** Bit ** Bit ~> Bit+mux = Circuit \(BPair (BPair (BBit s) (BBit a)) (BBit b)) -> BBit <$> fresh (Mux s a b)++-- | A register's output starts at the given value. Each clock edge replaces it with its input+-- from the preceding cycle. All registers update simultaneously.+register :: Bool -> Bit ~> Bit+register initial = Circuit \(BBit a) -> BBit <$> fresh (Register initial a)++-- | A netlist with typed boundaries. Disconnected components are omitted.+type Netlist :: Wires -> Wires -> Type+data Netlist a b where+  Netlist :: (KnownWires a, KnownWires b) => Bundle a -> Bundle b -> IM.IntMap Driver -> Netlist a b++-- | Build a netlist, retaining precisely the components that can influence an output, including+-- through a register on a later cycle.+netlist :: Circuit a b -> Netlist a b+netlist (Circuit f) = Netlist ins outs (IM.restrictKeys ds (reachable IS.empty (ports outs)))+  where+    ((ins, outs), BuildState _ ds) = runBuild build (BuildState 0 IM.empty)+    build = do+      ins' <- freshBundle Input shape+      outs' <- f ins'+      pure (ins', outs')+    reachable seen [] = seen+    reachable seen (n : ns)+      | IS.member n seen = reachable seen ns+      | otherwise = reachable (IS.insert n seen) (inputs (ds IM.! n) ++ ns)++-- | A text netlist. Bit numbers are local to this netlist; bundle ports are ordered left to right.+renderNetlist :: Netlist a b -> String+renderNetlist (Netlist ins outs ds) =+  unlines $+    ["inputs " ++ show (ports ins), "outputs " ++ show (ports outs)]+      ++ [show n ++ " = " ++ show d | (n, d) <- IM.toAscList ds]++-- | A Graphviz graph of the same netlist used by the simulator. Register nodes show their+-- initial value. Copying is fan-out of an edge, and feedback aliases are small connection points.+toDot :: Netlist a b -> String+toDot (Netlist ins outs ds) =+  unlines $+    [ "digraph circuit {"+    , "rankdir=LR; bgcolor=transparent;"+    , "node [shape=box, style=rounded, fontname=Helvetica];"+    , "edge [fontname=Helvetica, fontsize=10];"+    ]+      ++ [wire n ++ " [shape=circle, label=\"in " ++ show i ++ "\"];" | (i, n) <- zip [0 :: Int ..] (ports ins), IM.member n ds]+      ++ ["{rank=same; " ++ unwords [wire n ++ ";" | (n, Register{}) <- IM.toAscList ds] ++ "}"]+      ++ ["{rank=sink; " ++ unwords ["o" ++ show i ++ ";" | i <- [0 .. length (ports outs) - 1]] ++ "}"]+      ++ concatMap draw (IM.toAscList ds)+      ++ concat+        [ ["o" ++ show i ++ " [shape=circle, label=\"out " ++ show i ++ "\"];", wire n ++ " -> o" ++ show i ++ ";"]+        | (i, n) <- zip [0 :: Int ..] (ports outs)+        ]+      ++ ["}"]+  where+    wire n = "w" ++ show n+    draw (_, Input) = []+    draw (n, d) =+      (wire n ++ " [" ++ attrs d ++ "];")+        : [ wire i ++ " -> " ++ wire n ++ " [headlabel=\"" ++ label ++ "\"" ++ layout d ++ "];"+          | (i, label) <- zip (inputs d) (portNames d)+          ]+    layout Register{} = ", constraint=false"+    layout _ = ""+    attrs (Alias _) = "shape=point, label=\"\""+    attrs (Register b _) = "shape=box, style=\"rounded,filled\", fillcolor=\"#dbeafe\", label=\"D " ++ bit b ++ "\""+    attrs d = "label=\"" ++ name d ++ "\""+    name (Constant b) = bit b+    name Not{} = "NOT"+    name And{} = "AND"+    name Or{} = "OR"+    name Xor{} = "XOR"+    name Mux{} = "MUX"+    name _ = ""+    bit False = "0"+    bit True = "1"+    portNames Mux{} = ["sel", "1", "0"]+    portNames Register{} = ["D"]+    portNames _ = repeat ""++-- | Verilog with scalar ports @in0@, @in1@, ... and @out0@, @out1@, ... in bundle order,+-- and a shared rising-edge clock @clk@. The caller supplies a valid Verilog module name.+-- Combinational cycles are rejected, and disconnected components are omitted.+--+-- Registers use @initial@ assignments to preserve their starting values in simulation;+-- synthesis support for initialization depends on the hardware target.+toVerilog :: String -> Netlist a b -> Either CircuitError String+toVerilog name graph@(Netlist ins outs ds) = do+  _ <- prepare graph+  pure $+    unlines $+      ["module " ++ name ++ "(" ++ List.intercalate ", " interface ++ ");"]+        ++ ["  " ++ declaration n d | (n, d) <- drivers]+        ++ ["  assign " ++ wire n ++ " = in" ++ show i ++ ";" | (i, n) <- inputPorts, IM.member n ds]+        ++ concatMap emit drivers+        ++ ["  assign out" ++ show i ++ " = " ++ wire n ++ ";" | (i, n) <- outputPorts]+        ++ ["endmodule"]+  where+    inputPorts = zip [0 :: Int ..] (ports ins)+    outputPorts = zip [0 :: Int ..] (ports outs)+    interface =+      ["input wire clk"]+        ++ ["input wire in" ++ show i | (i, _) <- inputPorts]+        ++ ["output wire out" ++ show i | (i, _) <- outputPorts]+    drivers = IM.toAscList ds+    wire n = "w" ++ show n+    declaration n Register{} = "reg " ++ wire n ++ ";"+    declaration n _ = "wire " ++ wire n ++ ";"+    emit (n, d) = case d of+      Input -> []+      Constant b -> assign (bit b)+      Not a -> assign ("~" ++ wire a)+      And a b -> assign (binary " & " a b)+      Or a b -> assign (binary " | " a b)+      Xor a b -> assign (binary " ^ " a b)+      Mux s a b -> assign (wire s ++ " ? " ++ wire a ++ " : " ++ wire b)+      Alias a -> assign (wire a)+      Register initial a ->+        [ "  initial " ++ wire n ++ " = " ++ bit initial ++ ";"+        , "  always @(posedge clk) " ++ wire n ++ " <= " ++ wire a ++ ";"+        ]+      where+        assign expression = ["  assign " ++ wire n ++ " = " ++ expression ++ ";"]+    binary op a b = wire a ++ op ++ wire b+    bit False = "1'b0"+    bit True = "1'b1"++-- | Bits participating in a combinational cycle. Every observable cycle must cross a register.+newtype CircuitError = CombinationalCycle [Int]+  deriving (Eq, Show)++-- | A circuit that passed combinational-cycle validation, carrying its current simulation state.+-- Composition and tensor preserve validity; unrestricted trace is available only before validation.+type Prepared :: CAT PREPARED+data Prepared a b where+  Prepared+    :: (KnownWires a, KnownWires b)+    => Simulator (Value @ Ready a) (Value @ Ready b) -> Prepared (Ready a) (Ready b)++instance CategoryOf PREPARED where+  type (~>) = Prepared+  type Ob a = (Is Ready a, KnownWires (UN Ready a))+instance Profunctor Prepared where+  dimap = dimapDefault+  r \\ Prepared{} = r+instance Promonad Prepared where+  id = Prepared id+  Prepared f . Prepared g = Prepared (f . g)+instance MonoidalProfunctor Prepared where+  one = Prepared one+  Prepared f ** Prepared g = Prepared (f ** g)+instance Monoidal PREPARED where+  type Unit = Ready Empty+  type a ** b = Ready (Pair (UN Ready a) (UN Ready b))+  withOb2 r = r+  leftUnitor = Prepared leftUnitor+  leftUnitorInv = Prepared leftUnitorInv+  rightUnitor = Prepared rightUnitor+  rightUnitorInv = Prepared rightUnitorInv+  associator = Prepared associator+  associatorInv = Prepared associatorInv+instance SymMonoidal PREPARED where+  swap = Prepared swap+instance (Ob a) => Comonoid (a :: PREPARED) where+  counit = Prepared counit+  comult = Prepared comult+instance (Ob a) => CocommutativeComonoid (a :: PREPARED)+instance CopyDiscard PREPARED++instance FunctorForRep Value where+  type Value @ Ready Bit = Sim Bool+  type Value @ Ready Empty = Sim ()+  type Value @ Ready (Pair a b) = Sim (Sample a, Sample b)+  fmap (Prepared machine) = machine++instance MonoidalProfunctor (Rep Value) where+  one = Rep one+  Rep f ** Rep g = Rep (f ** g)++-- | Cut the dependencies through registers and topologically order the combinational nodes.+-- Multiplexers depend on both data inputs, even when their selector is constant.+prepare :: Netlist a b -> Either CircuitError (Prepared (Ready a) (Ready b))+prepare (Netlist ins outs ds) = do+  order <- concat <$> traverse acyclic (stronglyConnComp [((n, d), n, deps d) | (n, d) <- IM.toAscList ds])+  let run state = Simulator \input ->+        let initial = IM.union (IM.fromList (inputValues ins input)) state+            evaluated = List.foldl' evaluate initial order+        in (output outs evaluated, run (IM.map (evaluated IM.!) registerInputs))+  pure (Prepared (run initialRegisters))+  where+    registers = IM.mapMaybe (\case Register b i -> Just (b, i); _ -> Nothing) ds+    initialRegisters = IM.map fst registers+    registerInputs = IM.map snd registers+    deps Register{} = []+    deps d = inputs d+    acyclic (AcyclicSCC (_, Input)) = Right []+    acyclic (AcyclicSCC (_, Register{})) = Right []+    acyclic (AcyclicSCC node) = Right [node]+    acyclic (CyclicSCC ns) = Left (CombinationalCycle (map fst ns))+    evaluate bs (n, d) = IM.insert n (value d) bs+      where+        get a = bs IM.! a+        value (Constant b) = b+        value (Not a) = not (get a)+        value (And a b) = get a && get b+        value (Or a b) = get a || get b+        value (Xor a b) = get a /= get b+        value (Mux s a b) = if get s then get a else get b+        value (Alias a) = get a+        value _ = get n++-- | Prepare a circuit once and simulate a sequence of clock cycles. Each output is observed+-- before the clock edge for the corresponding input.+simulate :: Circuit a b -> [Sample a] -> Either CircuitError [Sample b]+simulate circuit xs = do+  sim <- prepare (netlist circuit)+  pure (runSimulator (fmap @Value sim) xs) \\ sim
src/Proarrow/Category/Instance/DecoratedCospan.hs view
@@ -13,14 +13,16 @@  import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Action (MonoidalAction) import Proarrow.Category.Monoidal.Applicative (Alternative (..)) import Proarrow.Category.Monoidal.Closed (Closed (..))-import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosed (..), coactCC) 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.Category.Monoidal.Strength (Costrong (..)) import Proarrow.Colimit.BinaryCoproduct   ( HasBinaryCoproducts (..)   , HasCoproducts@@ -34,7 +36,7 @@   ) import Proarrow.Colimit.Initial (HasInitialObject (..)) import Proarrow.Colimit.Pushout (HasPushouts (..))-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, tgt)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), WrappedOb, dimapDefault, tgt, type (+->)) import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))  type data DECCOSPAN (f :: k -> Type) = DC k@@ -120,6 +122,16 @@ 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+  , HasCoproducts k+  , Alternative f+  , MonoidalAction (t :: (DECCOSPAN f, DECCOSPAN f) +-> DECCOSPAN f)+  )+  => Costrong t (DecCospan :: CAT (DECCOSPAN (f :: k -> Type)))+  where+  coact @a = coactCC @t @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/Diff.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE NoStarIsType #-}++-- | __Differentiable maps__ between products of real vector spaces, with their reverse derivatives.+-- An object is a list of dimensions, @'DF' '[n, m]@ for ℝⁿ × ℝᵐ, and an arrow is a map together+-- with its reverse derivative: given a point and a change of the output, the change of the input+-- it comes from. Running an arrow at a point gives the image together with the reverse derivative+-- there, so the backward pass reuses what the forward pass computed, as in Elliott's+-- /The simple essence of automatic differentiation/. Composition runs the maps forward and chains+-- the reverse derivatives backward, which is the chain rule, so a reverse derivative is never more+-- than a change of vectors passed back through each step.+--+-- The category is cartesian: copying a point is adding the changes that come back, and discarding+-- one is the zero change. Every object is a commutative monoid by adding vectors. 'toLens' gives+-- an arrow as a lens, with the map as the view and the reverse derivative as the update.+--+-- The reverse derivative is a function rather than an arrow of the category itself, so this is the+-- first-order part of a reverse derivative category: the derivative cannot be differentiated again.+module Proarrow.Category.Instance.Diff+  ( DIFF (..)+  , Diff (..)+  , forward+  , backward+  , diff+  , Point (..)+  , pattern Vector+  , coordinates+  , fromCoordinates+  , zero+  , add+  , scale+  , split+  , append+  , linear+  , pointwise+  , times+  , dot+  , matVec+  , matMat+  , broadcast+  , softmax+  , softmaxCrossEntropy+  , bilinear+  , constant+  , toLens+  , Forget+  , AsLens+  ) where++import Data.Coerce (coerce)+import Data.Kind (Type)+import Data.Proxy (Proxy (..))+import Data.Vector.Storable qualified as SV+import GHC.TypeNats (KnownNat, Nat, natVal, type (*))+import Prelude (Double, ($), (*), (+))+import Prelude qualified as P++import Proarrow.Category.Instance.Opposite (OPPOSITE (..), Op (..))+import Proarrow.Category.Instance.TensorNetwork (Size, TNET (..), dimsOf, fromVector, matMul, toVector)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.Hypergraph (cap)+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..))+import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Monoid (CocommutativeComonoid, CommutativeMonoid, Comonoid (..), Monoid (..))+import Proarrow.Object (KnownListOf (..), withKnownAppend, withKnownAssoc, type (++))+import Proarrow.Optic (OPTIC (..), Prostrong)+import Proarrow.Optic.Lens (Lens, LensFl, lens)++-- | Objects are lists of dimensions, the product of the spaces of those dimensions.+type data DIFF = DF [Nat]++-- | A point of a product of spaces, or a change of one: a vector of coordinates for each space.+-- Taking a point of a product apart and putting it together handles the vectors without copying+-- their coordinates.+type Point :: [Nat] -> Type+newtype Point ns = Point {vectors :: [SV.Vector Double]}++-- | A point of a single space.+pattern Vector :: SV.Vector Double -> Point '[n]+pattern Vector v = Point [v]++{-# COMPLETE Vector #-}++-- | The dimension of a space.+dim :: forall n. (KnownNat n) => P.Int+dim = P.fromIntegral (natVal (Proxy @n))++-- | The coordinates of a point, one space after the other.+coordinates :: Point ns -> SV.Vector Double+coordinates (Point vs) = SV.concat vs++-- | The point with the given coordinates, one space after the other.+fromCoordinates :: forall ns. (KnownListOf KnownNat ns) => SV.Vector Double -> Point ns+fromCoordinates = Point P.. go (dimsOf @ns)+  where+    go [] _ = []+    go (d : ds) v = let (l, r) = SV.splitAt d v in l : go ds r++-- | The origin, which is also the change that changes nothing.+{-# INLINE zero #-}+zero :: forall ns. (KnownListOf KnownNat ns) => Point ns+zero = Point (P.map (`SV.replicate` 0) (dimsOf @ns))++-- | The sum of two points, or two changes.+{-# INLINE add #-}+add :: Point ns -> Point ns -> Point ns+add (Point x) (Point y) = Point (P.zipWith (SV.zipWith (+)) x y)++-- | A point, or a change, multiplied by a number.+{-# INLINE scale #-}+scale :: Double -> Point ns -> Point ns+scale s (Point x) = Point (P.map (SV.map (s *)) x)++-- | A point of a product as its two parts.+{-# INLINE split #-}+split :: forall as bs. (KnownListOf KnownNat as) => Point (as ++ bs) -> (Point as, Point bs)+split = \(Point vs) -> let (l, r) = P.splitAt n vs in (Point l, Point r)+  where+    n = P.length (dimsOf @as)++-- | The point of a product with the given parts.+{-# INLINE append #-}+append :: Point as -> Point bs -> Point (as ++ bs)+append (Point l) (Point r) = Point (l P.++ r)++-- | A differentiable map: at a point, its image and its reverse derivative there, which takes a+-- change of the image to the change of the point it comes from.+type Diff :: CAT DIFF+data Diff a b where+  Diff+    :: forall as bs+     . (KnownListOf KnownNat as, KnownListOf KnownNat bs)+    => {run :: Point as -> (Point bs, Point bs -> Point as)}+    -> Diff (DF as) (DF bs)++-- | The map of an arrow.+{-# INLINE forward #-}+forward :: DF as ~> DF bs -> Point as -> Point bs+forward f x = P.fst (run f x)++-- | The reverse derivative of an arrow at a point.+{-# INLINE backward #-}+backward :: DF as ~> DF bs -> Point as -> Point bs -> Point as+backward f x = P.snd (run f x)++-- | The arrow with the given map and reverse derivative, for when the two share no work.+{-# INLINE diff #-}+diff+  :: (KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => (Point as -> Point bs) -> (Point as -> Point bs -> Point as) -> DF as ~> DF bs+diff f fb = Diff (\x -> (f x, fb x))++-- | The identity between two lists of spaces that are the same list.+same :: forall as bs. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => DF as ~> DF bs+same = Diff (\x -> (coerce x, coerce))++instance Profunctor Diff where+  dimap = dimapDefault+  r \\ Diff{} = r++instance Promonad Diff where+  id = same+  Diff g . Diff f = Diff \x -> let (y, fb) = f x; (z, gb) = g y in (z, fb P.. gb)++-- | Differentiable maps between products of real vector spaces.+instance CategoryOf DIFF where+  type (~>) = Diff+  type Ob a = (Is DF a, KnownListOf KnownNat (UN DF a))++instance MonoidalProfunctor Diff where+  one = id+  Diff @as @bs f ** Diff @cs @ds g =+    withKnownAppend @KnownNat @as @cs $+      withKnownAppend @KnownNat @bs @ds $+        Diff \x ->+          let (a, c) = split @as @cs x; (b, fb) = f a; (d, gb) = g c+          in (append b d, \dy -> let (db, dd) = split @bs @ds dy in append (fb db) (gb dd))++-- | The product of spaces as the tensor.+instance Monoidal DIFF where+  type Unit = DF '[]+  type a ** b = DF (UN DF a ++ UN DF b)+  withOb2 @a @b r = withObProd @DIFF @a @b r+  leftUnitor = id+  leftUnitorInv = id+  rightUnitor @(DF as) = withKnownAppend @KnownNat @as @'[] same+  rightUnitorInv @(DF as) = withKnownAppend @KnownNat @as @'[] same+  associator @(DF as) @(DF bs) @(DF cs) = withKnownAssoc @KnownNat @as @bs @cs same+  associatorInv @(DF as) @(DF bs) @(DF cs) = withKnownAssoc @KnownNat @as @bs @cs same++instance SymMonoidal DIFF where+  swap @(DF as) @(DF bs) =+    withKnownAppend @KnownNat @as @bs $+      withKnownAppend @KnownNat @bs @as $+        diff+          (\x -> let (a, b) = split @as @bs x in append b a)+          (\_ d -> let (db, da) = split @bs @as d in append da db)++-- | The one-point space.+instance HasTerminalObject DIFF where+  type TerminalObject = DF '[]+  terminate = constant zero++-- | The product of spaces: the reverse derivative of a pairing adds the changes of both parts.+instance HasBinaryProducts DIFF where+  type a && b = DF (UN DF a ++ UN DF b)+  withObProd @(DF as) @(DF bs) r = withKnownAppend @KnownNat @as @bs r+  fst @(DF as) @(DF bs) = withKnownAppend @KnownNat @as @bs $ diff (P.fst P.. split @as @bs) (\_ da -> append da (zero @bs))+  snd @(DF as) @(DF bs) = withKnownAppend @KnownNat @as @bs $ diff (P.snd P.. split @as @bs) (\_ db -> append (zero @as) db)+  Diff @_ @bs f &&& Diff @_ @cs g =+    withKnownAppend @KnownNat @bs @cs $+      Diff \x ->+        let (b, fb) = f x; (c, gb) = g x+        in (append b c, \d -> let (db, dc) = split @bs @cs d in add (fb db) (gb dc))++-- | Copying a point: the changes that come back are added.+instance (KnownListOf KnownNat ns) => Comonoid (DF ns :: DIFF) where+  counit = terminate+  comult = id &&& id++instance (KnownListOf KnownNat ns) => CocommutativeComonoid (DF ns :: DIFF)+instance CopyDiscard DIFF++-- | Adding vectors: the change of a sum is passed back to both terms.+instance (KnownListOf KnownNat ns) => Monoid (DF ns :: DIFF) where+  mempty = constant zero+  mappend = withKnownAppend @KnownNat @ns @ns $ diff (\x -> let (a, b) = split @ns @ns x in add a b) (\_ d -> append d d)++instance (KnownListOf KnownNat ns) => CommutativeMonoid (DF ns :: DIFF)++-- | A linear map, given as a tensor network, its input and result each the vector of a tensor's+-- entries. The change of the input is the change of the result through the 'dual' of the map.+linear+  :: forall as bs+   . (KnownListOf KnownNat as, KnownListOf KnownNat bs, KnownNat (Size as), KnownNat (Size bs))+  => (TN as :: TNET Double) ~> TN bs+  -> DF '[Size as] ~> DF '[Size bs]+linear f =+  diff+    (\(Vector x) -> Vector (toVector (f . fromVector @'[] x)))+    (\_ (Vector dz) -> Vector (toVector (dual f . fromVector @'[] dz)))++-- | A function applied to each coordinate, given with its derivative.+pointwise :: (KnownNat n) => (Double -> Double) -> (Double -> Double) -> DF '[n] ~> DF '[n]+pointwise f f' = diff (\(Vector x) -> Vector (SV.map f x)) (\(Vector x) (Vector d) -> Vector (SV.zipWith (*) (SV.map f' x) d))++-- | The coordinatewise product of two vectors: 'bilinear' with the merging spider, written out.+times :: forall n. (KnownNat n) => DF '[n, n] ~> DF '[n]+times = Diff \p ->+  let (Vector x, Vector y) = split @'[n] @'[n] p+  in (Vector (SV.zipWith (*) x y), \(Vector d) -> Point [SV.zipWith (*) d y, SV.zipWith (*) d x])++-- | The dot product of two vectors: 'bilinear' with the cap, which sums the products.+dot :: forall n. (KnownNat n) => DF '[n, n] ~> DF '[1]+dot = bilinear @'[n] @'[n] (cap @(TN '[n]))++-- | The product of an @m@ by @n@ matrix, given row by row, with a vector: 'matMat' with a single+-- column.+matVec :: forall m n. (KnownNat m, KnownNat n, KnownNat (m * n)) => DF '[m * n, n] ~> DF '[m]+matVec = matMat @m @n @1++-- | The product of an @m@ by @n@ matrix with an @n@ by @k@ matrix, both given row by row. With a+-- batch of @m@ vectors as the rows of the first, the second is a linear map applied to each of them.+-- It is 'bilinear' with the cap on the summed index, written out with 'matMul': the change of the+-- first matrix is the change of the result times the transposed second, and the change of the second+-- is the transposed first times the change of the result, which adds up the changes from the whole+-- batch.+matMat+  :: forall m n k+   . (KnownNat m, KnownNat n, KnownNat k, KnownNat (m * n), KnownNat (n * k), KnownNat (m * k))+  => DF '[m * n, n * k] ~> DF '[m * k]+matMat = Diff \p ->+  let (Vector x, Vector w) = split @'[m * n] @'[n * k] p+  in ( Vector (matMul P.False P.False m k n x w)+     , \(Vector dy) -> Point [matMul P.False P.True m n k dy w, matMul P.True P.False n k m x dy]+     )+  where+    m = dim @m+    n = dim @n+    k = dim @k++-- | A vector copied to each of the @b@ rows of a matrix, given row by row: for adding the same+-- vector to each of a batch of @b@ vectors. The change of the vector adds up the rows of the change+-- of the matrix.+broadcast :: forall m b. (KnownNat m, KnownNat b, KnownNat (b * m)) => DF '[m] ~> DF '[b * m]+broadcast =+  diff+    (\(Vector v) -> Vector (SV.concat (P.replicate b v)))+    (\_ (Vector d) -> Vector (P.foldl' (SV.zipWith (+)) (SV.replicate m 0) (rows b m d)))+  where+    m = dim @m+    b = dim @b++-- | The softmax of each of the @b@ rows of a matrix of scores, given row by row: the exponentials of+-- a row divided by their sum, for each of a batch of @b@ vectors a probability for each of @k@+-- classes. The change of a row of scores is the probabilities times the change of the row minus its+-- average under them.+softmax :: forall k b. (KnownNat k, KnownNat b, KnownNat (b * k)) => DF '[b * k] ~> DF '[b * k]+softmax = Diff \(Vector z) ->+  let ps = P.map (SV.map P.exp P.. logSoftmax) (rows b k z)+  in ( Vector (SV.concat ps)+     , \(Vector d) ->+         Vector+           ( SV.concat+               ( P.zipWith+                   (\p dr -> let average = SV.sum (SV.zipWith (*) dr p) in SV.zipWith (\q e -> q * (e P.- average)) p dr)+                   ps+                   (rows b k d)+               )+           )+     )+  where+    k = dim @k+    b = dim @b++-- | The cross-entropy of the softmax of each of the @b@ rows of a matrix of scores against the same+-- row of a matrix of target probabilities, both given row by row, summed over the rows: the loss of+-- a classifier on a batch. With the softmax computed along, the change of the scores is the+-- probabilities minus the targets, for targets that sum to 1, and the change of the targets is+-- minus the logarithms of the probabilities.+softmaxCrossEntropy :: forall k b. (KnownNat k, KnownNat b, KnownNat (b * k)) => DF '[b * k, b * k] ~> DF '[1]+softmaxCrossEntropy = Diff \x ->+  let (Vector z, Vector t) = split @'[b * k] @'[b * k] x+      logPs = P.map logSoftmax (rows b k z)+      logP = SV.concat logPs+  in ( Vector (SV.singleton (P.negate (SV.sum (SV.zipWith (*) t logP))))+     , \(Vector d) ->+         let s = SV.head d+             scores lp tr = let mass = SV.sum tr in SV.zipWith (\l e -> s * (P.exp l * mass P.- e)) lp tr+         in Point [SV.concat (P.zipWith scores logPs (rows b k t)), SV.map (\l -> P.negate (s * l)) logP]+     )+  where+    k = dim @k+    b = dim @b++-- | A bilinear map, given as a tensor network from the tensor product of its two inputs, each input+-- and the result the vector of a tensor's entries: 'linear' in each input. The change of one input+-- is the change of the result through the 'dual' of the map with the other input fixed.+bilinear+  :: forall as bs cs+   . ( KnownListOf KnownNat as+     , KnownListOf KnownNat bs+     , KnownListOf KnownNat cs+     , KnownNat (Size as)+     , KnownNat (Size bs)+     , KnownNat (Size cs)+     )+  => (TN (as ++ bs) :: TNET Double) ~> TN cs+  -> DF '[Size as, Size bs] ~> DF '[Size cs]+bilinear f = withKnownAppend @KnownNat @as @bs $ Diff \p ->+  let (Vector x, Vector y) = split @'[Size as] @'[Size bs] p+      tx = fromVector @'[] @as x+      ty = fromVector @'[] @bs y+      withY = f . (obj @(TN as) ** ty) . rightUnitorInv @_ @(TN as)+      withX = f . (tx ** obj @(TN bs))+  in ( Vector (toVector (f . (tx ** ty)))+     , \(Vector dz) ->+         let tdz = fromVector @'[] dz+         in Point [toVector (dual withY . tdz), toVector (dual withX . tdz)]+     )++-- | The logarithms of the softmax of a vector, with its largest entry taken out before the+-- exponentials so that they cannot overflow.+logSoftmax :: SV.Vector Double -> SV.Vector Double+logSoftmax z = SV.map (P.subtract logSum) z+  where+    m = SV.maximum z+    logSum = m + P.log (SV.sum (SV.map (\x -> P.exp (x P.- m)) z))++-- | The @b@ rows of length @k@ of a matrix given row by row.+rows :: P.Int -> P.Int -> SV.Vector Double -> [SV.Vector Double]+rows b k v = [SV.slice (j * k) k v | j <- P.enumFromTo 0 (b P.- 1)]++-- | The map to a fixed point, whose reverse derivative is the zero change.+constant :: forall as bs. (KnownListOf KnownNat as, KnownListOf KnownNat bs) => Point bs -> DF as ~> DF bs+constant p = Diff (P.const (p, P.const zero))++-- | An arrow as a lens: the map is the view, and the reverse derivative the update. Composing+-- arrows and composing their lenses agree, which is the chain rule; 'AsLens' is the functor. A lens+-- views and updates separately, so the update runs the map again.+toLens :: DF as ~> DF bs -> Lens (Point as) (Point as) (Point bs) (Point bs)+toLens f = lens (forward f) (P.uncurry (backward f))++-- | The underlying functions: a differentiable map as a function from the points of its source to+-- those of its target, forgetting the reverse derivative.+data family Forget :: DIFF +-> Type++instance FunctorForRep Forget where+  type Forget @ a = Point (UN DF a)+  fmap f@Diff{} = forward f++-- | Arrows as lenses, by 'toLens'. The lens of an arrow goes the other way, so this is a functor into+-- the opposite of the category of lenses, and that it is a functor is the chain rule.+data family AsLens :: DIFF +-> OPPOSITE (OPTIC Type Type (Prostrong LensFl))++instance FunctorForRep AsLens where+  type AsLens @ a = OP (OPT (Point (UN DF a)) (Point (UN DF a)))+  fmap f@Diff{} = Op (toLens f)
src/Proarrow/Category/Instance/IntConstruction.hs view
@@ -18,7 +18,7 @@ import Proarrow.Category.Monoidal.StarAutonomous (ExpSA, StarAutonomous (..), applySA, currySA, expSA) import Proarrow.Category.Monoidal.Strength (TracedMonoidal) import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), dimapDefault, obj, (\\))-import Proarrow.Tools.SMC (SYN (F, (:**)), lift, toSMC, (**))+import Proarrow.Tools.SMC (SYN (F, (:**)), lift, toSMC, toSMC1, (**), (-<)) import Proarrow.Tools.SMC qualified as SMC  data INT k = I k k@@ -39,7 +39,7 @@ isoToInt f g = Int (swap @k @b @a . (f M.** g)) \\ f \\ g  fromInt :: forall {k} (a :: k) b m. (TracedMonoidal k) => (I a m ~> I b m) -> a ~> b-fromInt (Int f) = toSMC @(F a) \a -> SMC.do+fromInt (Int f) = toSMC1 \a -> SMC.do   let f' = lift @(F a :** F m) @(F m :** F b) f   rec (m, b) <- f' (a ** m)   b@@ -68,12 +68,10 @@   Int @ap @am @bp @bm f ** Int @cp @cm @dp @dm g =     withOb2 @(INT k) @(I ap am) @(I cp cm) $       withOb2 @(INT k) @(I bp bm) @(I dp dm) $-        Int $ toSMC @((F ap :** F cp) :** (F bm :** F dm)) \x -> SMC.do-          let f' = lift @(F ap :** F bm) @(F am :** F bp) f-              g' = lift @(F cp :** F dm) @(F cm :** F dp) g+        Int $ toSMC @((F ap :** F cp) :** (F bm :** F dm)) @((F am :** F cm) :** (F bp :** F dp)) \x -> SMC.do           ((ap, cp), (bm, dm)) <- x-          (am, bp) <- f' (ap ** bm)-          (cm, dp) <- g' (cp ** dm)+          (am, bp) <- f -< (ap, bm)+          (cm, dp) <- g -< (cp, dm)           (am ** cm) ** (bp ** dp)  -- | The monoidal tensor is pointwise, tensoring of the plus and minus parts.
src/Proarrow/Category/Instance/OpenHypergraph.hs view
@@ -33,6 +33,10 @@   , box   , openHypergraph   , unsafeOpenHypergraph+  , SomeHypergraph (..)+  , substitute+  , substituteWith+  , unsafeSubstituteWith   , isomorphic   , sameSort @@ -40,15 +44,26 @@   , SomeArrow (..)   , someArrow   , readBack-  , readBackWith+  , Wiring+  , permutations+  , copyDiscard+  , frobenius+  , frobeniusWith+  , tracedWith+  , layered      -- * Simplifying   , SIMPLIFY   , Prim   , unsafePrim   , prim+  , prim0+  , prim1+  , prim2+  , prim3   , simplify-  , simplifyWith+  , simplifyHypergraph+  , simplifyFlat   ) where  import Control.Monad (foldM, msum)@@ -56,7 +71,7 @@ import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.Map.Strict qualified as M-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, isJust, isNothing) import Data.Ord (comparing) import Data.Set qualified as Set import Data.Type.Equality (type (~))@@ -65,11 +80,13 @@ import Prelude qualified as P  import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..))-import Proarrow.Category.Instance.FinHask (FINHASK (..), FinHask (..))+import Proarrow.Category.Instance.FinHask (FINHASK (..), FinHask (..), unionFind) import Proarrow.Category.Instance.Sub (SUBCAT (..), Sub (..))-import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor, type (**)) import Proarrow.Category.Monoidal.Applicative (Alternative (..))-import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, Sized (..), traceHG)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius, Hypergraph, Sized (..), cupS, traceHG)+import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal) import Proarrow.Category.Monoidal.Strictified   ( Fold   , Strictified (..)@@ -79,15 +96,14 @@   , 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.Core (CategoryOf (..), Hom, Kind, OB, Ob', Profunctor, Promonad (..), UN, obj, (//)) import Proarrow.Functor (Functor (..))-import Proarrow.Monoid (comultS, counitS, mappendS, memptyS)+import Proarrow.Monoid (CocommutativeComonoid, Supplies, comultS, counitS, mappendS, memptyS) import Proarrow.Object   ( KnownListOf (..)   , ListOf (..)@@ -95,10 +111,13 @@   , appendListOf   , lengthListOf   , someOfList+  , withKnownAppend   , withKnownListOf   , withListOf+  , pattern Objs   ) import Proarrow.Optic.Iso (DecidableIso (..), withIso)+import Proarrow.Tools.ContractionOrder (Plan (..), planContraction)  -- * Sorts @@ -172,7 +191,7 @@ -- | 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+  withObCoprod @a @b r = withKnownAppend @SortOb @(PortSorts @s (UN SUB a)) @(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)))])))@@ -259,9 +278,17 @@     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.+-- | The open hypergraph with the given nodes, boundaries and boxes. The first argument lists the+-- sorts of the nodes, and a node is referred to by its position in that list, counting from 0. The+-- second and third arguments give, for each wire of @as@ and of @bs@ in order, the node it is+-- attached to, and each box lists the nodes of its inputs and of its outputs. A node that occurs+-- several times joins all those wires and ports. Fails with a message unless every node referred+-- to exists and every wire has a sort isomorphic to that of its node.+--+-- The product of a box @a@ from @x@ to @y@ and a box @b@ from @y@ to @z@ has nodes of the sorts+-- @x@, @y@ and @z@, with @y@ shared between the boxes:+--+-- > openHypergraph @'[x] @'[z] [sx, sy, sz] [0] [2] [Box a [0] [1], Box b [1] [2]] openHypergraph   :: forall {s} l (as :: [s]) (bs :: [s])    . (SortList as, SortList bs, DecidableIso s)@@ -286,10 +313,10 @@   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.+-- | 'openHypergraph' without its checks, with the same arguments: the boundaries must have as many+-- wires as their sorts, every wire and box must be attached to nodes that exist, and every wire must+-- have the sort of its node. Only for hypergraphs that satisfy this by construction, such as those+-- that 'simplify' is given, which trusts the sorts to be equal. unsafeOpenHypergraph   :: forall {s} l (as :: [s]) (bs :: [s])    . (SortList as, SortList bs)@@ -304,6 +331,136 @@     (Sub (FinHask (M.fromList (P.zip universeF (P.fmap (Port @_ @ns) outs)))))     (Boxes (P.fmap (P.fmap Port) boxList)) +-- | An open hypergraph whose boundaries are known at runtime, for replacing a labelled box.+type SomeHypergraph :: Kind -> Type -> Type+data SomeHypergraph s l where+  SomeHypergraph :: (a :: OPENHG s l) ~> b -> SomeHypergraph s l++-- | Replace every box by the diagram assigned to its label. Each replacement must have as many+-- inputs and outputs as the box, in the same order, with isomorphic sorts. All replacements are+-- glued together in one union-find pass. Shared nodes, repeated ports and isolated nodes are kept.+-- Replacement labels are not substituted again.+--+-- Adapted from the functor-application construction in §9 of Wilson and Zanasi,+-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>, restricted to an+-- identity object map. This implementation uses maps and union-find rather than the paper's+-- data-parallel representation.+substitute+  :: forall {s} l m a b+   . (DecidableIso s)+  => (l -> SomeHypergraph s m)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (Wires (WireSorts a) ~> (Wires (WireSorts b) :: OPENHG s m))+substitute replace hg =+  hg // do+    (nodes, ins, outs, boxes) <- substituteParts byIso replace (hypergraphParts hg)+    P.pure (unsafeOpenHypergraph nodes ins outs boxes)++-- | Apply an object map and a generator map to an open hypergraph. Each source sort becomes a list+-- of target sorts, and each box is replaced by a diagram with the expanded inputs and outputs.+-- Every occurrence of a node uses the same expanded nodes, including repeated ports and boundaries.+-- An empty list removes a node; an isolated node expands to one isolated node per target sort.+-- The resulting boundaries are known at runtime, so the result is a 'SomeHypergraph'.+--+-- The object map must send isomorphic source sorts to lists of pairwise isomorphic target sorts+-- for composition to be preserved. Replacement boundaries are checked as in 'substitute'.+--+-- Adapted from the functor-application construction in §9 of Wilson and Zanasi,+-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>.+-- This implementation uses lists, maps and union-find rather than the paper's data-parallel representation.+substituteWith+  :: forall {s} {t} l m a b+   . (DecidableIso t)+  => (SomeSort s -> [SomeSort t])+  -> (l -> SomeHypergraph t m)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (SomeHypergraph t m)+substituteWith = substituteWithAligned byIso++-- | 'substituteWith' without comparing sorts. Replacement boundaries must have the sorts+-- specified by the object map, in order. Arity is still checked. For typed primitive translations+-- whose source and replacement ports agree by construction; otherwise use 'substituteWith'.+unsafeSubstituteWith+  :: forall {s} {t} l m a b+   . (SomeSort s -> [SomeSort t])+  -> (l -> SomeHypergraph t m)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (SomeHypergraph t m)+unsafeSubstituteWith = substituteWithAligned trusted++substituteWithAligned+  :: forall {s} {t} l m a b+   . Align t+  -> (SomeSort s -> [SomeSort t])+  -> (l -> SomeHypergraph t m)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (SomeHypergraph t m)+substituteWithAligned al mapSort replace hg = do+  let (original, ins, outs, boxes) = hypergraphParts hg+      expanded = P.fmap mapSort original+      sizes = P.fmap P.length expanded+      offsets = P.scanl (P.+) 0 sizes+      segments = M.fromList (P.zip [0 ..] (P.zipWith (\offset n -> [offset .. offset P.+ n P.- 1]) offsets sizes))+      ports = P.concatMap (segments M.!)+  (nodes, inputs', outputs', boxes') <-+    substituteParts+      al+      replace+      (P.concat expanded, ports ins, ports outs, [Box x (ports i) (ports o) | Box x i o <- boxes])+  let sortAt = M.fromList (P.zip [0 ..] nodes)+  reifySorts (P.fmap (sortAt M.!) inputs') \ @as ->+    reifySorts (P.fmap (sortAt M.!) outputs') \ @bs ->+      P.pure (SomeHypergraph (unsafeOpenHypergraph @m @as @bs nodes inputs' outputs' boxes'))++substituteParts+  :: forall {s} l m+   . Align s+  -> (l -> SomeHypergraph s m)+  -> ([SomeSort s], [P.Int], [P.Int], [Box l P.Int])+  -> P.Either P.String ([SomeSort s], [P.Int], [P.Int], [Box m P.Int])+substituteParts al replace (original, ins, outs, bs) = do+  let sortAt = M.fromList (P.zip [0 ..] original)+      add (offset, ns, boxes, joins) (Box x i o) =+        case replace x of+          SomeHypergraph replacement ->+            let (nodes, ri, ro, rb) = hypergraphParts replacement+                replacementSorts = M.fromList (P.zip [0 ..] nodes)+                matches ports boundary =+                  lineUpAll al (P.fmap (sortAt M.!) ports) (P.fmap (replacementSorts M.!) boundary)+                shift n = offset P.+ n+            in if matches i ri P.&& matches o ro+                 then+                   P.Right+                     ( offset P.+ P.length nodes+                     , nodes : ns+                     , P.fmap (P.fmap shift) rb : boxes+                     , (P.zip i (P.fmap shift ri) P.++ P.zip o (P.fmap shift ro)) : joins+                     )+                 else P.Left "substitute: a replacement boundary has different arity or sorts"+  (nodeCount, chunks, boxes, joins) <- foldM add (P.length original, [original], [], []) bs+  let nodeSorts = P.concat (P.reverse chunks)+      root = unionFind (P.concat joins)+      roots = M.fromList [(n, root n) | n <- [0 .. nodeCount P.- 1]]+      quotient = M.fromList (P.zip (M.elems roots) nodeSorts)+      indices = M.fromList (P.zip (M.keys quotient) [0 ..])+      renumber = (M.!) (P.fmap (indices M.!) roots)+  P.pure+    ( M.elems quotient+    , P.fmap renumber ins+    , P.fmap renumber outs+    , P.fmap (P.fmap renumber) (P.concat (P.reverse boxes))+    )++hypergraphParts :: forall {s} l a b. (a :: OPENHG s l) ~> b -> ([SomeSort s], [P.Int], [P.Int], [Box l P.Int])+hypergraphParts (DecCospan @c (Sub (FinHask l)) (Sub (FinHask r)) (Boxes bs)) =+  ( sortList @s @(PortSorts @s (UN SUB c))+  , P.fmap unPort (M.elems l)+  , P.fmap unPort (M.elems r)+  , P.fmap (P.fmap unPort) bs+  )+  where+    unPort (Port i) = i+ -- | Whether two open hypergraphs differ only in the names of their nodes, the order of their boxes -- and their sorts up to isomorphism: a bijection between the nodes that keeps their sorts, agrees -- with both boundaries and takes the boxes of one to those of the other.@@ -355,96 +512,498 @@ 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)+-- | Wiring operations, feedback and box scheduling. 'permutations' and 'copyDiscard' reject+-- cycles; 'frobenius' supplies its cup-and-cap trace. 'tracedWith' replaces the feedback policy+-- with the target's trace while keeping the wiring operations and contraction plan.+-- Read-back reduces estimated swap cost; 'layered' also places independent boxes side by side.+type Wiring :: Kind -> Type+data Wiring s = Wiring+  { wiringFeedback :: Feedback s+  , wiringScheduling :: Scheduling+  , wiringSize :: P.Maybe (SomeSort s -> P.Int)+  , runWiring+      :: forall l a b+       . Align s+      -> Feedback s+      -> Scheduling+      -> (SomeSort s -> P.Int)+      -> (l -> SomeArrow s)+      -> (a :: OPENHG s l) ~> b+      -> P.Either P.String (WireSorts a ~> WireSorts b)+  } --- | 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+-- | Only permutations: every node has one producer and one consumer. Nullary boxes and scalars+-- are allowed; copying, merging and discarding need stronger wiring operations. With 'tracedWith',+-- isolated loops are traced identities.+permutations :: (SymMonoidal s) => Wiring s+permutations = Wiring acyclic Sequential P.Nothing (\al fb mode sizeFn -> readBackDirected al fb mode sizeFn (P.== 1) permuteWires)+  where+    permuteWires bundle wanted =+      let positions = M.fromList (P.zip bundle [0 ..])+      in permuteThen (P.fmap (positions M.!) wanted)++-- | Each node has one producer and any number of consumers. Copy when a wire branches and+-- discard it when unused. Boxes with unused outputs still run; copying and discarding need not+-- be natural. Directed cycles are rejected unless 'tracedWith' enables the target's trace.+-- With tracing, nodes without producers feed themselves and their consumers through copying.+copyDiscard :: (CopyDiscard s) => Wiring s+copyDiscard =+  Wiring+    acyclic+    Sequential+    P.Nothing+    (\al fb mode sizeFn -> readBackDirected al fb mode sizeFn (P.const P.True) copyWires)++-- | Frobenius spiders with sizes from 'Sized', planned as in 'frobeniusWith'.+frobenius :: (Hypergraph s, Sized s) => Wiring s+frobenius = frobeniusWith sizeFromSized++-- | Frobenius spiders with the given wire sizes. State boxes are contracted as a tree, using+-- the cheaper of numpy's greedy order and min-fill elimination. Remaining boxes follow a path;+-- nodes are merged and discarded as soon as their other uses allow. This preserves the+-- contraction planner used by 'Proarrow.Tools.Einsum.einsum'. Feedback uses the trace from+-- Frobenius cups and caps. The given sizes also weight swap reduction, including wire routing+-- within state contractions; routing preserves the contraction tree and its eliminated indices.+frobeniusWith :: (Hypergraph s) => (SomeSort s -> P.Int) -> Wiring s+frobeniusWith sizeFn = Wiring hypergraphTrace Sequential (P.Just sizeFn) readBackFrobenius++-- | Use the target's trace for feedback, replacing the wiring's default feedback policy.+-- For example, @tracedWith copyDiscard@ supports copying, discarding and directed cycles.+tracedWith :: (TracedMonoidal s) => Wiring s -> Wiring s+tracedWith wiring = wiring{wiringFeedback = traced}++-- | Place independent boxes side by side with tensor, routing wires between layers. Swap reduction+-- uses the wiring's existing sizes, or 'Sized' when no sizes were supplied. Each crossing is weighted+-- by the product of the wire sizes. Wiring operations and feedback are unchanged.+-- Without this modifier boxes are placed one at a time, with uniform swap costs unless the wiring+-- supplies sizes, as 'frobenius' and 'frobeniusWith' do.+layered :: (Sized s) => Wiring s -> Wiring s+layered wiring =+  wiring{wiringScheduling = Layered, wiringSize = P.Just (fromMaybe sizeFromSized (wiringSize wiring))}++data Scheduling = Sequential | Layered++-- | How to close feedback wires, independently of the wiring operations.+type Feedback :: Kind -> Type+data Feedback s = Feedback+  { allowsCycles :: P.Bool+  , closeFeedback+      :: forall us xs ys+       . Sorts (us :: [s])+      -> Sorts xs+      -> Sorts ys+      -> (us ++ xs) ~> (us ++ ys)+      -> P.Either P.String (xs ~> ys)+  }++-- | Reject directed feedback. No trace constraint is required.+acyclic :: forall s. Feedback s+acyclic = Feedback P.False close+  where+    close+      :: forall us xs ys+       . Sorts (us :: [s])+      -> Sorts xs+      -> Sorts ys+      -> (us ++ xs) ~> (us ++ ys)+      -> P.Either P.String (xs ~> ys)+    close Nil _ _ f = P.Right f+    close _ _ _ _ = P.Left "readBack: feedback requires a trace"++-- | Close feedback with the target's trace. Requires no copying or merging.+traced :: forall s. (TracedMonoidal s) => Feedback s+traced = Feedback P.True (\us xs ys f -> P.Right (traceSorts (\ @u @x @y -> coact @Tensor @(Hom s) @u @x @y) us xs ys f))++-- | Close feedback with the trace derived from Frobenius cups and caps ('traceHG'). This keeps+-- the cup-and-cap form of hypergraph diagrams and needs no separate 'TracedMonoidal' instance.+hypergraphTrace :: (Hypergraph s) => Feedback s+hypergraphTrace = Feedback P.True (\us xs ys f -> P.Right (traceSorts (\ @u @x @y -> traceHG @u @x @y) us xs ys f))++-- | Interpret a graph using the given wiring, for example @readBack copyDiscard interpret graph@+-- or @readBack (tracedWith permutations) interpret graph@.+-- Sorts supplied from outside are compared by 'DecidableIso'; boxes are transported along the+-- resulting isomorphisms. Unsupported incidences or feedback return an error.+readBack   :: forall {s} l a b-   . (Hypergraph s, DecidableIso s)-  => (SomeSort s -> P.Int)+   . (DecidableIso s)+  => Wiring s   -> (l -> SomeArrow s)   -> (a :: OPENHG s l) ~> b   -> P.Either P.String (WireSorts a ~> WireSorts b)-readBackWith = readBackAligned (byIso @s)+readBack wiring =+  runWiring+    wiring+    (byIso @s)+    (wiringFeedback wiring)+    (wiringScheduling wiring)+    (fromMaybe (P.const 1) (wiringSize wiring))  -- | The read-back, with the sorts lined up by the given alignment.-readBackAligned+readBackFrobenius   :: forall {s} l a b-   . (Hypergraph s)+   . (SymMonoidal s, Supplies Frobenius s)   => Align s+  -> Feedback s+  -> Scheduling   -> (SomeSort s -> P.Int)   -> (l -> SomeArrow s)   -> (a :: OPENHG s l) ~> b   -> P.Either P.String (WireSorts a ~> WireSorts b)-readBackAligned al sizeFn interp hg@(DecCospan @c (Sub (FinHask legIn)) (Sub (FinHask legOut)) (Boxes boxList)) =+readBackFrobenius al fbChoice mode sizeFn interp hg =   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 ->+    arrows0 <-+      interpretBoxes+        al+        (sortAt M.!)+        interp+        "readBack: the arrow of a label does not have the sorts of its box"+        labelled+    let arrows =+          M.union+            arrows0+            (M.fromList [(j, pieceArrow al nodeSort arrows0 (routeTree (P.toInteger P.. sizeFn P.. nodeSort) t)) | (j, t) <- merged])+    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)+          initial = P.fmap KN (feedback lt P.++ shapeIns shape)+          wanted = P.fmap KL (feedback lt) P.++ P.fmap (outKey lt) (shapeOuts shape)+          plan bundle0 (t, layer) =+            let entries = [gateEntry (outKey lt) bx | bx <- layer]+                need = P.concatMap entryInputs entries+                made = P.concatMap entryOutputs entries+                carry = [k | k <- nubOrd (bundle0 P.++ need), live lt t k P.|| k `P.elem` made]+                whole = P.fmap identityEntry carry P.++ entries+            in (P.concatMap entryOutputs whole, whole)+          planned = P.snd (List.mapAccumL plan initial (P.zip [1 ..] layers))+          ordered = orderLayers (P.toInteger P.. sizeFn P.. nodeSort) initial wanted planned+          (bundle, body) = buildLayers al (transition al nodeSort []) arrows initial (Built start Same) ordered           final =             transition               al               nodeSort               (isolated shape boxes0)               bundle-              (P.fmap KL (feedback lt) P.++ P.fmap (outKey lt) (shapeOuts shape))+              wanted               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.Just to -> closeFeedback fbChoice 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]+    (shape, sortAt, labelled) = prepareReadBack hg     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)+    layers = boxLayers mode (feedback (lifetimes shape boxesIx (P.fmap (: []) order))) order+    lt = lifetimes shape boxesIx layers +-- Directed readers keep one wire per available node between boxes. Routing supplies the+-- current inputs and retains only those nodes needed by later boxes or the output boundary.+readBackDirected+  :: forall {s} l a b+   . (SymMonoidal s)+  => Align s+  -> Feedback s+  -> Scheduling+  -> (SomeSort s -> P.Int)+  -> (P.Int -> P.Bool)+  -> (forall xs. [Key] -> [Key] -> Built (xs :: [s]) -> Built xs)+  -> (l -> SomeArrow s)+  -> (a :: OPENHG s l) ~> b+  -> P.Either P.String (WireSorts a ~> WireSorts b)+readBackDirected al fbChoice mode sizeFn acceptsConsumers route interp hg =+  hg // do+    let (shape@(Shape _ ins outs), sortAt, numbered) = prepareReadBack hg+    (order, fbNodes) <- directedOrder (allowsCycles fbChoice) acceptsConsumers shape numbered+    arrows <- interpretBoxes al (sortAt M.!) interp "readBack: an arrow does not fit its box" numbered+    withListOf (P.fmap (sortAt M.!) fbNodes) \fb -> do+      let insS = sorts @s @(WireSorts a)+          outsS = sorts @s @(WireSorts b)+          start = appendListOf fb insS+          produced = Set.fromList (P.concatMap (outputs P.. P.snd) numbered)+          feedbackOutputs = Set.intersection (Set.fromList fbNodes) produced+          made n = if n `Set.member` feedbackOutputs then KL n else KN n+          wanted = P.fmap made fbNodes P.++ P.fmap KN outs+          layers = boxLayers mode fbNodes order+          uses = P.zip [0 :: P.Int ..] layers+          lastUse =+            M.fromListWith+              P.max+              ([(n, P.length layers) | n <- wanted] P.++ [(KN n, j) | (j, layer) <- uses, (_, bx) <- layer, n <- inputs bx])+          plan bundle0 (j, layer) =+            let carry = P.filter (\n -> M.findWithDefault (-1) n lastUse P.> j) bundle0+                entries = P.fmap identityEntry carry P.++ P.fmap (gateEntry made) layer+            in (P.concatMap entryOutputs entries, entries)+          initial = P.fmap KN (fbNodes P.++ ins)+          planned = P.snd (List.mapAccumL plan initial uses)+          ordered = orderLayers (P.toInteger P.. sizeFn P.. (sortAt M.!) P.. keyNode) initial wanted planned+          (bundle, body) = buildLayers al route arrows initial (Built start Same) ordered+      case route bundle wanted body of+        Built ys whole -> case alignSteps al ys (appendListOf fb outsS) of+          P.Just into -> closeFeedback fbChoice fb insS outsS (arrowOf ys into . arrowOf start whole)+          P.Nothing -> P.Left "readBack: the output boundary has other sorts"++-- Copy each available wire to its requested multiplicity, then permute the individual copies.+copyWires :: forall {s} xs. (CopyDiscard s) => [Key] -> [Key] -> Built (xs :: [s]) -> Built xs+copyWires bundle wanted body = permuteThen permutation (expand bundle `afterBuilt` body)+  where+    counts = M.fromListWith (P.+) [(n, 1 :: P.Int) | n <- wanted]+    count n = M.findWithDefault 0 n counts+    expanded = P.concatMap (\n -> P.replicate (count n) n) bundle+    numbered ns = P.snd (List.mapAccumL number M.empty ns)+    number seen n =+      let i = M.findWithDefault (0 :: P.Int) n seen+      in (M.insert n (i P.+ 1) seen, (n, i))+    positions = M.fromList (P.zip (numbered expanded) [0 ..])+    permutation = P.fmap (positions M.!) (numbered wanted)+    expand :: [Key] -> Sorts (ws :: [s]) -> Built ws+    expand [] Nil = Built Nil Same+    expand (n : ns) (Cons @x xs) = beside (single @x) (copies @x (count n)) xs (expand ns xs)+    expand _ _ = P.error "readBack: the bundle has other sorts"++-- The same node numbering is used by the planners and by box interpretation.+prepareReadBack+  :: forall {s} l a b+   . (a :: OPENHG s l) ~> b+  -> (Shape, M.Map P.Int (SomeSort s), [(P.Int, Box l P.Int)])+prepareReadBack hg =+  let (nodes, ins, outs, boxes) = hypergraphParts hg+  in (Shape [0 .. P.length nodes P.- 1] ins outs, M.fromList (P.zip [0 ..] nodes), P.zip [0 ..] boxes)++interpretBoxes+  :: forall {s} l+   . Align s+  -> (P.Int -> SomeSort s)+  -> (l -> SomeArrow s)+  -> P.String+  -> [(P.Int, Box l P.Int)]+  -> P.Either P.String (M.Map P.Int (SomeArrow s))+interpretBoxes al nodeSort interp message = P.fmap M.fromList P.. P.traverse checkBox+  where+    checkBox (i, Box x is os) = case interp x of+      arrow@(SomeArrow xs ys _)+        | lineUpAll al (someOfList xs) (P.fmap nodeSort is)+            P.&& lineUpAll al (someOfList ys) (P.fmap nodeSort os) ->+            P.Right (i, arrow)+        | P.otherwise -> P.Left message++-- Each node has at most one producer. With copying and tracing, a node without a producer+-- feeds itself and its consumers. Cut unavailable inputs of the first blocked box to schedule cycles.+directedOrder+  :: P.Bool+  -> (P.Int -> P.Bool)+  -> Shape+  -> [(P.Int, Box l P.Int)]+  -> P.Either P.String ([(P.Int, Box l P.Int)], [P.Int])+directedOrder canTrace acceptsConsumers sh boxes+  | P.not (P.all acceptsProducer (shapeNodes sh)) =+      P.Left "readBack: every node must have one producer"+  | P.not (P.all (\n -> n `Set.member` loops P.|| acceptsConsumers (M.findWithDefault 0 n consumerCounts)) (shapeNodes sh)) =+      P.Left "readBack: unsupported number of consumers"+  | P.not canTrace P.&& P.not (Set.null loops) = P.Left "readBack: isolated loops require a trace"+  | P.otherwise = go available0 ready counts [] (Set.toDescList sources)+  where+    producers = M.fromListWith (P.+) [(n, 1 :: P.Int) | n <- shapeIns sh P.++ P.concatMap (outputs P.. P.snd) boxes]+    consumerCounts = M.fromListWith (P.+) [(n, 1 :: P.Int) | n <- shapeOuts sh P.++ P.concatMap (inputs P.. P.snd) boxes]+    sources = Set.fromList (shapeNodes sh) `Set.difference` M.keysSet producers+    loops = sources `Set.difference` M.keysSet consumerCounts+    acceptsProducer n = case M.findWithDefault 0 n producers of+      1 -> P.True+      0 -> n `Set.member` loops P.|| (canTrace P.&& acceptsConsumers (1 P.+ M.findWithDefault 0 n consumerCounts))+      _ -> P.False+    available0 = Set.union sources (Set.fromList (shapeIns sh))+    counts = M.fromList [(i, P.length (P.filter (`Set.notMember` available0) (inputs bx))) | (i, bx) <- boxes]+    ready = M.keysSet (M.filter (P.== 0) counts)+    consumers = M.fromListWith (P.++) [(n, [i]) | (i, bx) <- boxes, n <- inputs bx]+    table = M.fromList boxes+    release acc n = P.foldl releaseBox acc (M.findWithDefault [] n consumers)+    releaseBox acc@(queue, remaining) i = case M.lookup i remaining of+      P.Nothing -> acc+      P.Just count ->+        let count' = count P.- 1+        in (if count' P.== 0 then Set.insert i queue else queue, M.insert i count' remaining)+    go available queue remaining acc cutsRev = case Set.minView queue of+      P.Nothing -> case M.lookupMin remaining of+        P.Nothing -> P.Right (P.reverse acc, P.reverse cutsRev)+        P.Just (i, _)+          | canTrace ->+              let missing = Set.fromList (inputs (table M.! i)) `Set.difference` available+                  ns = Set.toList missing+                  (next, counts') = P.foldl release (queue, remaining) ns+              in go (Set.union available missing) next counts' acc (P.reverse ns P.++ cutsRev)+          | P.otherwise -> P.Left "readBack: a directed cycle requires a trace"+      P.Just (i, rest) ->+        let bx = table M.! i+            fresh = Set.fromList (outputs bx) `Set.difference` available+            (next, counts') = P.foldl release (rest, M.delete i remaining) (Set.toList fresh)+        in go (Set.union available fresh) next counts' ((i, bx) : acc) cutsRev+ -- ** Planning +-- Pack the existing order into earliest dependency layers. Feedback inputs are supplied by the+-- trace, independently of the outputs that close it.+boxLayers :: Scheduling -> [P.Int] -> [(P.Int, Box l P.Int)] -> [[(P.Int, Box l P.Int)]]+boxLayers Sequential _ order = P.fmap (: []) order+boxLayers Layered feedbackNodes order =+  P.fmap P.reverse (M.elems (M.fromListWith (P.++) [(t, [bx]) | (t, bx) <- placed]))+  where+    cut = Set.fromList feedbackNodes+    (_, placed) = List.mapAccumL place M.empty order+    place made bx@(_, b) =+      let t :: P.Int+          t = 1 P.+ P.maximum (0 : [M.findWithDefault 0 n made | n <- inputs b, n `Set.notMember` cut])+          made' = P.foldr (\n -> M.insertWith P.max n t) made (outputs b)+      in (made', (t, bx))++-- Carried wires participate in layout as identity boxes, without adding hypergraph nodes.+data LayerEntry = LayerEntry+  { entryInputs :: [Key]+  , entryOutputs :: [Key]+  , entryBox :: P.Maybe P.Int+  }++identityEntry :: Key -> LayerEntry+identityEntry k = LayerEntry [k] [k] P.Nothing++gateEntry :: (P.Int -> Key) -> (P.Int, Box l P.Int) -> LayerEntry+gateEntry made (i, bx) = LayerEntry (P.fmap KN (inputs bx)) (P.fmap made (outputs bx)) (P.Just i)++-- Four alternating sweeps exchange adjacent entries only when the total estimated routing cost+-- decreases. Layer membership and each box's port order stay fixed; ties retain their order.+orderLayers+  :: (Key -> P.Integer) -> [Key] -> [Key] -> [[LayerEntry]] -> [[LayerEntry]]+orderLayers size initial wanted layers0 =+  P.snd (List.foldl' sweep start passes)+  where+    -- Start identities near their incoming positions, even across several idle layers.+    -- Moving them one layer at a time can require cost-neutral swaps.+    seeded = P.snd (List.mapAccumL seed initial layers0)+    seed bundle layer =+      let positions = M.fromList (P.zip bundle [0 :: P.Int ..])+          position entry = P.minimum (P.length bundle : [i | k <- entryInputs entry, P.Just i <- [M.lookup k positions]])+          ordered = List.sortOn position layer+      in (P.concatMap entryOutputs ordered, ordered)+    originalCost = cost layers0+    seededCost = cost seeded+    start+      | originalCost P.== 0 P.|| originalCost P.<= seededCost = (originalCost, layers0)+      | P.otherwise = (seededCost, seeded)+    cost layers =+      P.sum+        ( P.zipWith+            crossings+            (initial : P.fmap (P.concatMap entryOutputs) layers)+            (P.fmap (P.concatMap entryInputs) layers P.++ [wanted])+        )+    -- Shared wires use the same position; Frobenius merging is an estimate of spider routing.+    crossings from to =+      let positions = M.fromList (P.zip from [0 :: P.Int ..])+          edges = [(i, size k) | k <- to, P.Just i <- [M.lookup k positions]]+      in weightedInversions edges+    passes :: [[(P.Int, P.Int)]]+    passes = [forward, backward, forward, backward]+    forward = [(i, j) | (i, layer) <- P.zip [0 ..] layers0, j <- [0 .. P.length layer P.- 2]]+    backward = P.reverse forward+    sweep current@(0, _) _ = current+    sweep current [] = current+    sweep current (move : rest) = sweep (improve current move) rest+    improve current@(best, layers) (i, j) = case P.splitAt i layers of+      (pre, layer : rest) ->+        let from = case P.reverse pre of+              [] -> initial+              previous : _ -> P.concatMap entryOutputs previous+            to = case rest of+              [] -> wanted+              following : _ -> P.concatMap entryInputs following+            -- Reordering a layer changes only its incoming and outgoing frontiers.+            localCost entries = crossings from (P.concatMap entryInputs entries) P.+ crossings (P.concatMap entryOutputs entries) to+            candidate = exchangeAt j layer+            next = best P.+ localCost candidate P.- localCost layer+        in if next P.< best then (next, pre P.++ (candidate : rest)) else current+      _ -> current+    exchangeAt n xs = case P.splitAt n xs of+      (pre, a : b : rest) -> pre P.++ (b : a : rest)+      _ -> xs++-- Crossing costs use Integer so large object sizes do not overflow during comparison.+weightedInversions :: [(P.Int, P.Integer)] -> P.Integer+weightedInversions edges = P.sum [a P.* b | (i, a) : rest <- List.tails edges, (j, b) <- rest, i P.> j]++-- Reorder the exposed wires of proper subtrees. Changing one boundary affects only its own+-- transition and its parent's, so each accepted swap reduces their combined routing cost.+-- The root boundary, contraction tree and the indices eliminated at each node stay fixed.+routeTree :: (Key -> P.Integer) -> Tree -> Tree+routeTree size t0 = List.foldl' (\t backwards -> visit backwards (P.const 0) P.False t) t0 passes+  where+    passes :: [P.Bool]+    passes = [P.False, P.True, P.False, P.True]+    visit backwards above movable t =+      let rebuilt = case t of+            Leaf{} -> t+            Merge l r ks+              | backwards ->+                  let r' = visit backwards (\out -> routingCost (treeKeys l P.++ out) ks) P.True r+                      l' = visit backwards (\out -> routingCost (out P.++ treeKeys r') ks) P.True l+                  in Merge l' r' ks+              | P.otherwise ->+                  let l' = visit backwards (\out -> routingCost (out P.++ treeKeys r) ks) P.True l+                      r' = visit backwards (\out -> routingCost (treeKeys l' P.++ out) ks) P.True r+                  in Merge l' r' ks+          cost tree = routingCost (treeMade tree) (treeKeys tree) P.+ above (treeKeys tree)+          positions = [0 .. P.length (treeKeys rebuilt) P.- 2]+          improve current@(best, tree) i =+            let ks = treeKeys tree+                candidate = case P.splitAt i ks of+                  (pre, a : b : rest) -> setKeys (pre P.++ (b : a : rest)) tree+                  _ -> tree+                next = cost candidate+            in if next P.< best then (next, candidate) else current+      in if movable+           then P.snd (List.foldl' improve (cost rebuilt, rebuilt) (if backwards then P.reverse positions else positions))+           else rebuilt+    setKeys ks (Leaf i made _) = Leaf i made ks+    setKeys ks (Merge l r _) = Merge l r ks+    routingCost from to =+      let kinds = groupOrder from to (nubOrd (from P.++ to))+          ranks = M.fromList (P.zip kinds [0 :: P.Int ..])+          grouped wires = weightedInversions [(ranks M.! k, size k) | k <- wires]+      in grouped from P.+ grouped to++-- Route each frontier and tensor its gates with the identities of the carried wires.+buildLayers+  :: forall s (xs :: [s])+   . (SymMonoidal s)+  => Align s+  -> (forall ws. [Key] -> [Key] -> Built (ws :: [s]) -> Built ws)+  -> M.Map P.Int (SomeArrow s)+  -> [Key]+  -> Built xs+  -> [[LayerEntry]]+  -> ([Key], Built xs)+buildLayers al route arrows = go+  where+    go :: [Key] -> Built xs -> [[LayerEntry]] -> ([Key], Built xs)+    go bundle body [] = (bundle, body)+    go bundle body (layer : rest) =+      let need = P.concatMap entryInputs layer+          made = P.concatMap entryOutputs layer+          run :: forall ws. Sorts (ws :: [s]) -> Built ws+          run = build layer+      in go made (run `afterBuilt` route bundle need body) rest+    build :: forall ws. [LayerEntry] -> Sorts (ws :: [s]) -> Built ws+    build [] ws = Built ws Same+    build (entry : rest) ws = case entryBox entry of+      P.Nothing ->+        let (identities, remaining) = P.span (isNothing P.. entryBox) rest+        in carryThen (1 P.+ P.length identities) (build remaining) ws+      P.Just i -> case arrows M.! i of+        arrow@(SomeArrow ins _ _) -> case rest of+          [] -> boxThen al arrow ws+          _ -> splitSorts (lengthListOf ins) ws \pre post -> beside pre (boxThen al arrow pre) post (build rest post)+ -- | The nodes of an open hypergraph, numbered from 0, and its boundaries. data Shape = Shape {shapeNodes :: [P.Int], shapeIns :: [P.Int], shapeOuts :: [P.Int]} @@ -475,15 +1034,21 @@ 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}+-- | Some of the boxes without inputs, contracted as a tree, with how many of them touch each node.+data Piece = Piece {pieceTree :: Tree, pieceCounts :: M.Map P.Int 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.+-- | The boxes without inputs contracted with each other as a tree, until no two share a node, in+-- the order of 'planContraction'. contractStates :: (Set.Set P.Int -> P.Double) -> Shape -> [Ix] -> [Piece]-contractStates size sh bxs = contract [leaf b | b@(_, bx) <- bxs, P.null (inputs bx)]+contractStates size sh bxs = P.fmap run (planContraction size (P.const P.True) needed (P.fmap touches states))   where+    states = [b | b@(_, bx) <- bxs, P.null (inputs bx)]+    -- the nodes of the boundary and of the boxes with inputs+    needed =+      Set.fromList+        (shapeIns sh P.++ shapeOuts sh P.++ [n | b@(_, bx) <- bxs, P.not (P.null (inputs bx)), n <- Set.toList (touches b)])+    run (Factor k) = leaf (M.fromList (P.zip [0 ..] states) M.! k)+    run (Contract a b) = merge (run a) (run b)     -- how many boxes and boundaries touch each node; a piece needs to keep a node that they touch     -- more often than its own boxes do     total =@@ -495,22 +1060,11 @@     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+      in Piece (Leaf i (P.fmap KN (outputs bx)) (keysIn open (P.fmap KN (outputs bx)))) counts     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]+      in Piece (Merge (pieceTree a) (pieceTree b) (keysIn open (treeKeys (pieceTree a) P.++ treeKeys (pieceTree b)))) counts  -- | The boxes read back along a path: those with inputs, the states left on their own, and one box -- for each piece of more than one state, numbered after the boxes, with those pieces.@@ -564,10 +1118,10 @@   -- 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}+lifetimes :: Shape -> [Ix] -> [[Ix]] -> Lifetimes+lifetimes sh bxs layers = Lifetimes{feedback = fb, outKey = key, live = alive}   where-    layerOf = M.fromList (P.zip (P.fmap P.fst order) [1 :: P.Int ..])+    layerOf = M.fromList [(i, t) | (t, layer) <- P.zip [1 :: P.Int ..] layers, (i, _) <- layer]     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@@ -590,7 +1144,9 @@ -- | 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+  :: forall s+   . (SymMonoidal s, Supplies Frobenius 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@@ -599,38 +1155,13 @@     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+   . (SymMonoidal s, Supplies Frobenius 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]@@ -682,24 +1213,80 @@   :: 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 from the tensor unit as a box with no inputs and one output.+prim0 :: forall {k} (a :: k). (Monoidal k) => Unit ~> a -> Wires '[] ~> (Wires '[a] :: SIMPLIFY k)+prim0 f@Objs = prim (Str f)++-- | An arrow as a box with one input and one output.+prim1 :: forall {k} (a :: k) b. (CategoryOf k) => a ~> b -> Wires '[a] ~> (Wires '[b] :: SIMPLIFY k)+prim1 f@Objs = prim (singleton f)++-- | An arrow from a tensor as a box with two inputs and one output.+prim2+  :: forall {k} (a :: k) b c+   . (Monoidal k, Ob a, Ob b)+  => (a ** b ~> c) -> Wires '[a, b] ~> (Wires '[c] :: SIMPLIFY k)+prim2 f@Objs = prim (Str f)++-- | An arrow from a left-associated tensor as a box with three inputs and one output.+-- Reassociates the right-associated port list to the arrow's input tensor.+prim3+  :: forall {k} (a :: k) b c d+   . (Monoidal k, Ob a, Ob b, Ob c)+  => (a ** b ** c ~> d) -> Wires '[a, b, c] ~> (Wires '[d] :: SIMPLIFY k)+prim3 f@Objs = prim (Str (f . associatorInv @k @a @b @c))+ -- | An arrow as the label of a box with any sorts. Only for boxes whose sorts are equal to the -- arrow's by construction, as for 'unsafeOpenHypergraph'. unsafePrim :: SomeArrow k -> Prim k unsafePrim = 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)+-- | Read a primitive graph using the given wiring. Primitive sorts are trusted, so+-- 'DecidableIso' is unnecessary: for example, @simplify copyDiscard graph@ can execute a graph+-- as a Haskell function.+simplify+  :: forall {k} a b+   . Wiring k+  -> (a :: SIMPLIFY k) ~> b+  -> P.Either P.String (WireSorts a ~> WireSorts b)+simplify wiring =+  runWiring+    wiring+    trusted+    (wiringFeedback wiring)+    (wiringScheduling wiring)+    (fromMaybe (P.const 1) (wiringSize wiring))+    (\(Prim arrow) -> arrow) --- | '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+-- | Interpret a primitive graph in its hypergraph target, with wire sizes from 'Sized'.+-- This is 'simplify' with 'frobenius': every graph is supported and+-- primitive sorts are trusted, so the result needs no 'P.Either'.+simplifyHypergraph+  :: forall {k} a b+   . (Hypergraph k, Sized k)+  => (a :: SIMPLIFY k) ~> b+  -> WireSorts a ~> WireSorts b+simplifyHypergraph = P.either P.error P.id P.. simplify frobenius +-- | 'simplifyHypergraph' with every box bent into a state on all its wires, its inputs turned into outputs+-- with cups. The read-back then contracts the whole network in the order of 'planContraction',+-- instead of following the flow from inputs to outputs, and needs no traces for cycles. For+-- computing with a term rather than drawing it, as the result is drawn with cups and caps.+simplifyFlat :: forall {k} a b. (Hypergraph k, Sized k) => (a :: SIMPLIFY k) ~> b -> WireSorts a ~> WireSorts b+simplifyFlat (DecCospan l r (Boxes bxs)) =+  simplifyHypergraph (DecCospan l r (Boxes (P.fmap bent bxs)))+  where+    bent bx@(Box (Prim (SomeArrow xs ys f)) is os)+      | P.null is = bx+      | P.otherwise = Box (Prim (bendInputs xs ys f)) [] (P.reverse is P.++ os)++-- | An arrow with its inputs bent over to its outputs with cups, one at a time from the first, so+-- that the state's wires are the inputs in reverse order followed by the outputs.+bendInputs :: forall {s} (as :: [s]) bs. (Hypergraph s) => Sorts as -> Sorts bs -> as ~> bs -> SomeArrow s+bendInputs Nil ys f = SomeArrow Nil ys f+bendInputs (Cons @x @rest xs) ys f =+  withIsListOf xs P.$ bendInputs xs (Cons @x ys) ((obj @'[x] ** f) . (cupS @x ** obj @rest))+ -- | The size of a sort, from 'Sized'. sizeFromSized :: forall s. (Sized s) => SomeSort s -> P.Int sizeFromSized (Some @x) = sizeOf @s @x@@ -800,6 +1387,16 @@ single :: forall {s} (x :: s). (Ob' x) => Sorts '[x] single = Cons @x Nil +-- | Leave the first wires unchanged while building a step on the rest.+carryThen+  :: forall {s} (xs :: [s])+   . (Monoidal s)+  => P.Int+  -> (forall (ys :: [s]). Sorts ys -> Built ys)+  -> Sorts xs+  -> Built xs+carryThen n build xs = splitSorts n xs \pre post -> beside pre (Built pre Same) post (build post)+ -- | The box on the first wires, and the rest of the wires unchanged. boxThen :: (Monoidal s) => Align s -> SomeArrow s -> Sorts (xs :: [s]) -> Built xs boxThen al (SomeArrow as bs f) xs = splitSorts (lengthListOf as) xs \pre post -> case alignSteps al pre as of@@ -808,7 +1405,7 @@  -- | 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 :: (SymMonoidal 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@@@ -817,27 +1414,29 @@       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 :: (SymMonoidal 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+  :: (SymMonoidal s, Supplies Frobenius 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+  :: (SymMonoidal s, Supplies Frobenius 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 :: forall {s} (x :: s) pre. (SymMonoidal s, Supplies Frobenius 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)@@ -848,7 +1447,7 @@   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 :: forall {s} (x :: s). (CocommutativeComonoid 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))@@ -858,23 +1457,23 @@ -- | 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+   . (SymMonoidal s)+  => (forall (u :: s) x y. (Ob u, Ob x, Ob y) => u ** x ~> u ** y -> x ~> y)+  -> Sorts us   -> Sorts xs   -> Sorts ys   -> (us ++ xs) ~> (us ++ ys)   -> xs ~> ys-traceSorts Nil _ _ f = f-traceSorts us xs ys f =+traceSorts _ Nil _ _ f = f+traceSorts close 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+        case (splitMany @us, splitMany @xs, concatMany @ys) of+          (splitUs@Objs, splitXs@Objs, concatYs@Objs) ->+            splitMany @ys+              . Str+                ( close @(Fold us) @(Fold xs) @(Fold ys)+                    (unStr ((concatMany @us ** concatYs) . f . (splitUs ** splitXs)))+                )+              . concatMany @xs
+ src/Proarrow/Category/Instance/Simulator.hs view
@@ -0,0 +1,82 @@+-- | Clocked state machines. Each step consumes one input and produces one output and the next+-- machine. Composition and tensor advance every component once per clock cycle.+--+-- >>> runSimulator (stateless not) [False, True]+-- [True,False]+-- >>> runSimulator (stateless (+ 1) . stateless (* 2)) [1 :: Int, 2]+-- [3,5]+module Proarrow.Category.Instance.Simulator+  ( SIMULATOR (..)+  , Simulator (..)+  , stateless+  , step+  , runSimulator+  ) where++import Data.Kind (Type)+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Core (CAT, CategoryOf (..), Is, Profunctor (..), Promonad (..), UN, dimapDefault)+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))++type data SIMULATOR = Sim Type++-- | A machine and its current state, represented by its next step.+type Simulator :: CAT SIMULATOR+data Simulator a b where+  Simulator :: (a -> (b, Simulator (Sim a) (Sim b))) -> Simulator (Sim a) (Sim b)++-- | Apply a function independently in every clock cycle.+stateless :: (a -> b) -> Simulator (Sim a) (Sim b)+stateless f = machine+  where+    machine = Simulator \x -> (f x, machine)++instance CategoryOf SIMULATOR where+  type (~>) = Simulator+  type Ob a = Is Sim a+instance Profunctor Simulator where+  dimap = dimapDefault+  r \\ Simulator{} = r+instance Promonad Simulator where+  id = stateless \x -> x+  Simulator f . Simulator g = Simulator \x ->+    let (y, g') = g x+        (z, f') = f y+    in (z, f' . g')+instance MonoidalProfunctor Simulator where+  one = id+  Simulator f ** Simulator g = Simulator \(x, y) ->+    let (x', f') = f x+        (y', g') = g y+    in ((x', y'), f' ** g')+instance Monoidal SIMULATOR where+  type Unit = Sim ()+  type a ** b = Sim (UN Sim a, UN Sim b)+  withOb2 r = r+  leftUnitor = stateless \((), x) -> x+  leftUnitorInv = stateless ((),)+  rightUnitor = stateless \(x, ()) -> x+  rightUnitorInv = stateless (,())+  associator = stateless \((x, y), z) -> (x, (y, z))+  associatorInv = stateless \(x, (y, z)) -> ((x, y), z)+instance SymMonoidal SIMULATOR where+  swap = stateless \(x, y) -> (y, x)+instance (Ob a) => Comonoid (a :: SIMULATOR) where+  counit = stateless (const ())+  comult = stateless \x -> (x, x)+instance (Ob a) => CocommutativeComonoid (a :: SIMULATOR)+instance CopyDiscard SIMULATOR++-- | Observe the current output and advance one clock cycle.+step :: Simulator (Sim a) (Sim b) -> a -> (b, Simulator (Sim a) (Sim b))+step (Simulator run) = run++-- | Run a sequence of inputs, starting from the machine's current state.+runSimulator :: Simulator (Sim a) (Sim b) -> [a] -> [b]+runSimulator _ [] = []+runSimulator machine (x : xs) =+  let (y, next) = step machine x+  in y : runSimulator next xs
src/Proarrow/Category/Instance/TensorNetwork.hs view
@@ -31,6 +31,7 @@   , toVector   , fromEntries   , entries+  , matMul   ) where  import Data.Complex (Complex, conjugate)@@ -39,7 +40,6 @@ 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 ((:~:) (..))@@ -72,8 +72,9 @@ 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.Object (KnownListOf (..), eqListOf, mapListOf, withKnownAppend, withKnownAssoc, type (++)) import Proarrow.Optic.Iso (DecidableIso (..), isoFromEquality)+import Proarrow.Tools.ContractionOrder qualified as Plan  -- | 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.@@ -87,9 +88,9 @@   kernel = contractLoop   {-# INLINE kernel #-} -  -- | The conjugate of an entry, which the dagger takes: the identity on real numbers.-  conj :: e -> e-  conj = P.id+  -- | The conjugation of entries, when it is not the identity, as for complex numbers.+  conj :: P.Maybe (e -> e)+  conj = P.Nothing    -- | A fast matrix product, which a contraction of two factors that is one is handed to.   gemm :: P.Maybe (Gemm e)@@ -101,7 +102,7 @@ instance Scalar P.Float where   gemm = gemmFloat instance Scalar (Complex P.Double) where-  conj = conjugate+  conj = P.Just conjugate   gemm = gemmComplexDouble  -- | The loop that 'kernel' runs, written once for every type: a loop over each axis of the result,@@ -162,9 +163,15 @@ 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}+-- | A dense factor: its entries, row by row over its axes, the node of each axis, and the+-- conjugates of its entries. Both are computed when first needed, so the dagger can swap them, and+-- each factor conjugates its entries at most once.+data Factor e = Factor {axes :: [Node], values :: ~(SV.Vector e), conjugates :: ~(SV.Vector e)} +-- | The factor with the given axes and entries.+factor :: (Scalar e) => [Node] -> SV.Vector e -> Factor e+factor as vs = Factor as vs (P.maybe vs (`SV.map` vs) conj)+ -- | 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]}@@ -196,7 +203,7 @@   => 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])+  | P.otherwise = TensorNetwork (Net dims is os [factor (os P.++ is) vs])   where     dims = dimsOf @as P.++ dimsOf @bs     is = wires @as@@ -283,18 +290,21 @@ contract dims f g keep summed   | P.Just mm <- gemm, P.Just r <- viaGemm mm dims f g keep summed = r   | P.otherwise =-      Factor+      factor         keep         ( kernel-            [(dims P.!! x, stride dims f x, stride dims g x) | x <- keep]-            (offsets f summed)-            (offsets g summed)+            [(dims P.!! x, sf x, sg x) | x <- keep]+            (offsets sf summed)+            (offsets sg summed)             (values f)             (values g)         )   where+    sf = stride dims f+    sg = stride dims g     -- 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)+    offsets s [x] = UV.generate (dims P.!! x) (* s x)+    offsets s xs = P.foldl (\acc x -> step acc (dims P.!! x) (s x)) (UV.singleton 0) xs     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@@ -306,8 +316,8 @@   | 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)+unit :: (Scalar 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,@@ -316,8 +326,8 @@ 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))+  | 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)]@@ -335,9 +345,11 @@       | 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.+-- 0 when it has none. Applied to a factor alone, it works out the strides of its axes once. 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]+stride dims f = \node -> P.sum [s | (a, s) <- axisStrides, a == node]+  where+    axisStrides = P.zip (axes f) (P.drop 1 (P.scanr (*) 1 (P.fmap (dims P.!!) (axes f))))  -- | Whether no element of the list is there twice. distinct :: [Node] -> P.Bool@@ -363,6 +375,21 @@ gemmWork :: Int gemmWork = 4096 +-- | The product of two matrices given row by row, for products that are not part of a network:+-- whether the first and the second are stored transposed, the numbers of rows, columns and summed+-- indices, and the two matrices; the result row by row. It is the contraction of two factors on the+-- nodes of the rows, the columns and the summed index, so large products go to 'gemm'.+matMul :: (Scalar e) => P.Bool -> P.Bool -> Int -> Int -> Int -> SV.Vector e -> SV.Vector e -> SV.Vector e+matMul ta tb rows cols inner a b =+  values+    ( contract+        [rows, cols, inner]+        (factor (if ta then [2, 0] else [0, 2]) a)+        (factor (if tb then [1, 2] else [2, 1]) b)+        [0, 1]+        [2]+    )+ -- | 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@@ -371,7 +398,7 @@     (P.fmap (dims P.!!) kept)     (P.fmap renumber is)     (P.fmap renumber os)-    (P.fmap relabel (scalars (loops P.++ sumOut reduced shared)))+    (P.fmap relabel (scalars (loops P.++ P.fmap (P.fst P.. run) plans)))   where     summed = [n | n <- [0 .. P.length dims - 1], n `Set.notMember` keptSet]     -- the number of factors on each node@@ -386,33 +413,40 @@     -- 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)))]+      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)+    sharedSet = Set.fromList shared+    -- the factors contracted in the order of 'Plan.planContraction', until no two share a summed node+    plans =+      Plan.planContraction+        (P.fromIntegral P.. extent dims P.. Set.toList)+        (`Set.member` sharedSet)+        keptSet+        (P.fmap (Set.fromList P.. axes) reduced)+    reducedAt = IM.fromList (P.zip [0 ..] reduced)+    -- the factor a plan makes, with how many of the factors in it touch each node+    run (Plan.Factor k) = let f = reducedAt IM.! k in (f, IM.fromList [(m, 1 :: Int) | m <- axes f])+    run (Plan.Contract a b) =+      let (f, cf) = run a+          (g, cg) = run b+          cs = IM.unionWith (+) cf cg+          both = nubOrd (axes f P.++ axes g)+          -- the shared nodes that no factor outside the two is on, summed out by this product+          ds = [m | m <- both, m `Set.member` sharedSet, cs IM.! m == factorsOn m]+          left = both 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 (`Set.member` sharedSet) left in now P.++ later+      in (contract dims f g keep ds, cs)     -- 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+      (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+    relabel f = f{axes = P.fmap renumber (axes f)}  -- | The new number of each of the given nodes: its place in the list. renumbering :: [Node] -> Node -> Node@@ -424,7 +458,7 @@   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+    shift f = f{axes = P.fmap (+ k) (axes f)}  -- | 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.@@ -438,7 +472,7 @@             [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]+            [h{axes = P.fmap node (axes h)} | h <- factors both]         )   where     both = besideNet f g@@ -463,13 +497,7 @@  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)))+withAppend = withKnownAppend @KnownNat @as @bs  -- | The arrow the other way round: its wiring with inputs and outputs swapped. transpose :: TensorNetwork (a :: TNET e) b -> TensorNetwork b a@@ -488,10 +516,10 @@   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.+-- | The conjugate transpose: the factors with their entries and conjugates swapped. '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]}+  dagger (TensorNetwork n) = TensorNetwork (transposeNet n){factors = [h{values = conjugates h, conjugates = values h} | h <- factors n]}  -- | A wire of dimension 0. instance (Scalar e) => HasInitialObject (TNET e) where@@ -534,8 +562,8 @@   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+  associator @(TN as) @(TN bs) @(TN cs) = withKnownAssoc @KnownNat @as @bs @cs straight+  associatorInv @(TN as) @(TN bs) @(TN cs) = withKnownAssoc @KnownNat @as @bs @cs straight  instance (Scalar e) => SymMonoidal (TNET e) where   swap @(TN as) @(TN bs) =
src/Proarrow/Category/Monoidal/Cartesian.hs view
@@ -9,6 +9,7 @@ -- points that way. module Proarrow.Category.Monoidal.Cartesian where +import Data.Kind (Type) import Prelude (($), type (~)) import Prelude qualified as P @@ -18,7 +19,7 @@ import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard) import Proarrow.Category.Monoidal.Distributive (Distributive (..), Traversable (..)) import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..), type (||))-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), lmap, type (+->))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), UN, lmap, type (+->)) import Proarrow.Limit.BinaryProduct   ( HasBinaryProducts (..)   , HasProducts@@ -62,6 +63,14 @@ -- | A category with products, viewed through 'PROD' as a monoidal category, is cartesian. instance (HasProducts k) => CopyDiscard (PROD k) +instance Closed (PROD Type) where+  -- The wrapper must also stay opaque until the helper's inlining phase.+  {-# INLINE [0] curry #-}+  type a ~~> b = PR (UN PR a ~~> UN PR b)+  withObExp @(PR a) @(PR b) r = withObExp @Type @a @b r+  curry (Prod f) = Prod (curryProd f)+  apply @(PR a) @(PR b) = Prod (applyProd @a @b)+ -- | In a cartesian category the tensor /is/ the product ('TensorIsProduct'), but GHC only applies -- that equation at the top of a type, never under another type family such as @('||')@, and -- using the quantified form of it directly sends the solver in circles. These two identities take@@ -95,6 +104,20 @@  class (Cartesian k, Closed k) => CCC k instance (Cartesian k, Closed k) => CCC k++-- | Currying with the product, obtained from 'curry' using the cartesian tensor/product equality.+-- It satisfies the currying bijection in the laws of 'Closed'.+-- Keep @INLINE [0]@ on a delegating instance method too, to preserve delayed inlining.+curryProd :: forall {k} (a :: k) b c. (CCC k, TensorIsProduct a b, Ob a, Ob b) => (a && b) ~> c -> a ~> (b ~~> c)+curryProd = curry @k @a @b+-- Delay exposing the underlying curry to limit dictionary expansion in nested SMC terms.+{-# INLINE [0] curryProd #-}++-- | Evaluation with the product, obtained from 'apply' using the cartesian tensor/product equality.+-- Together with 'curryProd' it satisfies the currying bijection in the laws of 'Closed'.+applyProd :: forall {k} (a :: k) b. (CCC k, TensorIsProduct (a ~~> b) a, Ob a, Ob b) => ((a ~~> b) && a) ~> b+applyProd = apply @k @a @b+{-# INLINE applyProd #-}  type Bicartesian k = (Cartesian k, Distributive k)
src/Proarrow/Category/Monoidal/Hypergraph.hs view
@@ -63,8 +63,13 @@  -- | 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.+-- when choosing contraction order and estimating swap cost in layered read-back.+--+-- Sizes should be nonnegative and invariant under isomorphism. For monoidal categories, prefer+-- a unit size of 1 and a tensor size equal to the product of the factors' sizes.+-- These are recommendations rather than laws: sizes may also be heuristic weights. A category+-- without a natural size can give every object size 2; the planner multiplies the weights of+-- separate wires in a bundle, even when 'sizeOf' itself does not preserve tensor products. type Sized :: Kind -> Constraint class (CategoryOf k) => Sized k where   sizeOf :: forall (a :: k). (Ob a) => Int
src/Proarrow/Category/Sheaf.hs view
@@ -370,14 +370,14 @@  -- | The sum coverage on a free category with binary coproducts: a sum is covered by its two -- injections. This is the syntactic site of Spiwack's post (see the module header). In the free--- bicartesian closed category 'Proarrow.Tools.CCC.Syntax', the booleans @TermF '+' TermF@ are+-- bicartesian closed category @FREE cs p@, the booleans @TermF '+' TermF@ are -- covered by @true@ and @false@. -- -- Read @p a@ as the ways of producing an @a@. Being a sheaf means @p Bool ≅ p TermF × p TermF@: -- every pair of branches has a conditional, and only one. With too many, a proof by cases -- establishes nothing. With too few, @if-then-else@ is not definable. On a representable the -- conditional is @'|||'@, which is why 'glue' below is @[t, e]@. The conditional on a test--- @f :: c '~>' Bool@ is 'Proarrow.Tools.CCC.either', which needs the distributive law as well.+-- @f :: c '~>' Bool@ uses the distributive law as well, as in 'Proarrow.Tools.CCC.caseOf'. -- -- __Stability does not hold.__ It would need every arrow into a sum to split its source into a -- sum (/extensivity/), and a free bicartesian category is not extensive. The restriction of
src/Proarrow/Object.hs view
@@ -23,6 +23,8 @@   , mapListOf   , lengthListOf   , appendListOf+  , withKnownAppend+  , withKnownAssoc   , eqListOf      -- * One object of many@@ -115,6 +117,20 @@ 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)++-- | The class for the elements of both lists.+withKnownAppend+  :: forall {k} (c :: OB k) as bs r. (KnownListOf c as, KnownListOf c bs) => ((KnownListOf c (as ++ bs)) => r) -> r+withKnownAppend = withKnownListOf (appendListOf (listOf @c @as) (listOf @c @bs))++-- | The class for the elements of three lists, appended either way round.+withKnownAssoc+  :: forall {k} (c :: OB k) as bs cs r+   . (KnownListOf c as, KnownListOf c bs, KnownListOf c cs)+  => ((KnownListOf c ((as ++ bs) ++ cs), KnownListOf c (as ++ (bs ++ cs))) => r) -> r+withKnownAssoc r =+  withKnownAppend @c @as @bs+    (withKnownAppend @c @(as ++ bs) @cs (withKnownAppend @c @bs @cs (withKnownAppend @c @as @(bs ++ cs) r)))  -- | Some type with the evidence @c@, which one known only at runtime. type SomeOf :: forall {k}. OB k -> Type
src/Proarrow/Optic/Action.hs view
@@ -15,7 +15,7 @@   ( Monoidal (..)   , MonoidalProfunctor (..)   , OplaxMonoidalRep-  , SymMonoidal+  , SymMonoidal (..)   , Tensor   , unpar0Rep   , unparRep@@ -55,6 +55,21 @@       withActP @act @f' @g' f' g' \ @y f2 g2 ->         withOb2 @_ @x @y $           k @(x ** y) (composeActs @act @x @y @a f1 f2) (decomposeActs @act @x @y @b g2 g1)++-- | Connect a tensor-action optic's forward and backward passes. The forward pass produces+-- the focus @a@ and a residual, which the backward pass consumes together with @b@ to produce+-- @t@. The residual is used once; no copying, discarding or tracing is required.+runMonoidalOptic+  :: forall {k} c (s :: k) t a b+   . (SymMonoidal k, (Ob a, Ob b) => c (ExOptic (ActFl Tensor) a b))+  => Optic c s t a b -> (s ** b) ~> (a ** t)+runMonoidalOptic o@Objs =+  withLegs @(ActFl Tensor) o \l r ->+    withActP @Tensor l r \ @m forward backward ->+      (obj @a ** backward)+        . associator @k @a @m @b+        . (swap @k @m @a ** obj @b)+        . (forward ** obj @b)  -- | An Eilenberg-Moore algebra for the monad @m@ (a representable 'Promonad' on @k@, acting as -- the functor @m '%' -@, see "Proarrow.Promonad"): a structure map @m % a ~> a@, coherent with the
src/Proarrow/Optic/Kaleidoscope.hs view
@@ -77,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 (..), lam, lift, toSMC, (!))+import Proarrow.Tools.SMC (SYN (..), lam, toSMC, (!), (-<)) import Proarrow.Tools.SMC qualified as SMC  -- * Carriers@@ -177,11 +177,8 @@   Rep @x2 @_ @x1 l@Objs ** Rep @y2 @_ @y1 r@Objs =     withOb2 @k @x2 @y2 (Rep both)     where-      both = toSMC @(F x1 :** F y1) @(F m :-> F x2 :** F y2) \p -> SMC.do-        let l' = lift @(F x1) @(F m :-> F x2) l-            r' = lift @(F y1) @(F m :-> F y2) r-        (x, y) <- p-        lam \i -> l' x ! i SMC.** r' y ! i+      both = toSMC @(F x1 :** F y1) @(F m :-> F x2 :** F y2) \(x, y) ->+        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))@@ -192,7 +189,7 @@     withOb2 @k @a @y (Rep strong)     where       strong = toSMC @(F a :** F x) @(F m :-> F a :** F y) \(a, x) ->-        lam \i -> a SMC.** lift @(F x) @(F m :-> F y) p x ! i+        lam \i -> a SMC.** (p -< x) ! i instance (Closed k, HasCoproducts k, Comonoid (m :: k)) => Strong CoprodAction (Rep (Exp m) :: k +-> k) where   act @(COPR a) (Rep @y p) =     p //
src/Proarrow/Optic/Traversal.hs view
@@ -124,6 +124,10 @@ type Traversal (s :: k) (t :: k) a b = Optic (Prostrong TravFl) s t a b type Traversal' s a = Traversal s s a a +-- | An applicative Haskell effect absorbs traversal witnesses through 'travP'.+instance (P.Applicative f) => Prostrong TravFl (Star (Prelude f)) where+  proact (p :.: r :.: q) = travP p q r+ -- | Distribute any 'StrongDistributiveProfunctor' (not only a @Star f@, the van-Laarhoven shape) -- through any optic that is at least a 'Traversal', by handing it to 'travP'. --
src/Proarrow/Optics.hs view
@@ -93,7 +93,7 @@      -- | Exactly one eliminator per flavor: 'view', 'review', 'preview', 'matching', 'over',     -- 'foldMapOf', 'traverseOf', 'monTraverseOf', 'powerGrateOf', 'cotraverseOf', 'kaleidoscopeOf',-    -- 'zipWithOf', 'classifyOf' and 'tracerOf' /run/ the optic; 'withIso', 'withLens',+    -- 'zipWithOf', 'classifyOf', 'tracerOf' and 'runMonoidalOptic' /run/ the optic; 'withIso', 'withLens',     -- 'withMonLens', 'withPrism', 'withGrate' and 'withGlass' /recover its two legs/.   , view   , review@@ -109,6 +109,7 @@   , zipWithOf   , classifyOf   , tracerOf+  , runMonoidalOptic   , withIso   , withLens   , withMonLens@@ -143,6 +144,7 @@   , algebraicLens   , classifyOf   , classifyingLens+  , runMonoidalOptic   , (.?)   ) import Proarrow.Optic.AffineFold (AffineFold, preview, (^?))
src/Proarrow/Path.hs view
@@ -69,7 +69,7 @@ type instance Fold (p ::: (q ::: ps)) = Fold (q ::: ps) :.: p  -- | Which per-element property a 'SPath' witnesses. @Tight@ plays the role of the tight--- (vertical, 'Representable') legs of the @Prof@ equipment; a later @Cotight@ would do+-- ('Representable') legs of the @Prof@ equipment; a later @Cotight@ would do -- the same for 'Proarrow.Profunctor.Corepresentable.Corepresentable' legs. data Tag = Prof | Tight @@ -122,10 +122,10 @@ withAssoc :: forall ps qs rs t r. (IsOb t ps) => ((Assoc ps qs rs) => r) -> r withAssoc r = r --- | A well-formed (horizontal) path: every element is a plain 'Profunctor'.+-- | A well-formed profunctor path: every element is a plain 'Profunctor'. type IsPath = IsOb Prof --- | A tight (vertical) path: every element is 'Representable'.+-- | A tight path: every element is 'Representable'. type IsTight = IsOb Tight  -- | A tight path is, in particular, a well-formed path ('Representable' implies
src/Proarrow/Profunctor/Free.hs view
@@ -16,7 +16,14 @@ 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.OpenHypergraph+  ( SIMPLIFY+  , WireSorts+  , Wires+  , frobeniusWith+  , prim1+  , simplify+  ) import Proarrow.Category.Instance.Prof (Prof (..)) import Proarrow.Category.Instance.Sub (Forget, On, SUBCAT (..), Sub (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), swap)@@ -26,7 +33,7 @@ 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 (..), singleton, (==))+import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), (==)) import Proarrow.Core   ( CAT   , CategoryOf (..)@@ -255,5 +262,5 @@ 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)+  liftK = prim1+  retractK f = P.either P.error unStr (simplify (frobeniusWith (P.const 2)) f)
src/Proarrow/Profunctor/Instance/Star.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE RecursiveDo #-}  -- | 'Star' embeds a functor @f@ as a profunctor with the functor on the target side: -- @Star f a b = a ~> f b@. It is the representable profunctor of @f@; for a Haskell monad @m@,@@ -12,6 +13,7 @@ import Data.Traversable qualified as P import Prelude qualified as P +import Control.Monad.Fix qualified as P import Proarrow.Category.Enriched.Thin (DecidableProfunctor (..), Thin, ThinProfunctor (..), mapDecision) import Proarrow.Category.Instance.Nat (ApplyAction, Nat' (..), type (.->) (..)) import Proarrow.Category.Instance.Prof (Prof (..))@@ -19,7 +21,7 @@ import Proarrow.Category.Monoidal.Action (CoprodAction, ProdAction, SubAction) import Proarrow.Category.Monoidal.Applicative (Alternative (..), Applicative (..)) import Proarrow.Category.Monoidal.Distributive (Distributive, Traversable (..), Traversing, baseTraverse, repTraverse)-import Proarrow.Category.Monoidal.Strength (MonStrong, Strong (..), strongId)+import Proarrow.Category.Monoidal.Strength (Costrong (..), 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 (+->))@@ -57,6 +59,11 @@ instance (P.Monad m) => Promonad (Star (Prelude m)) where   id = Star (Prelude . P.pure)   Star g . Star f = Star \a -> Prelude (unPrelude (f a) P.>>= (unPrelude . g))++instance (P.MonadFix m) => Costrong Tensor (Star (Prelude m)) where+  coact (Star f) = Star P.$ \x -> Prelude P.$ do+    rec (a, y) <- unPrelude (f (a, x))+    P.return y  composeStar :: (Functor f) => Star f :.: Star g :~> Star (Compose f g) composeStar (Star f :.: Star g) = Star (Compose . map g . f)
src/Proarrow/Squares.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE AllowAmbiguousTypes #-}  -- | Squares, specialized to profunctors: the counterpart of "Proarrow.Equipment.Squares" in--- @proarrow-equipment@. Horizontal legs are 'Proarrow.Path.Path's of profunctors, vertical legs--- 'Representable' profunctors (the tight morphisms of the @Prof@ equipment).+-- @proarrow-equipment@. Data flows rightward along representable wires; effects flow+-- downward along profunctor wires. Paths of profunctors are read right to left, so+-- @[p, q, r]@ is drawn as @r, q, p@ and has composite @r :.: q :.: p@. Paths of+-- 'Representable' profunctors are read top to bottom. --+-- 'vId' is the identity for '(===)', and 'hId' is the identity for '(|||)'.+-- -- A square's payload is @'Fold' (p '+++' f) :~> 'Fold' (g '+++' q)@, the fold of each side's -- concatenated path, instead of @'Fold' f ':.:' 'Fold' p :~> 'Fold' q ':.:' 'Fold' g@. -- "Proarrow.Path" does the associator\/unitor bookkeeping once, and since @'Nil' '+++' ps@ and@@ -15,15 +19,8 @@  import Proarrow.Adjunction (Proadjunction) import Proarrow.Adjunction qualified as Adj-import Proarrow.Category.Instance.Prof qualified as P-import Proarrow.Category.Monoidal (Monoidal (..), type (**))-import Proarrow.Category.Monoidal.Action (Act, ActionAt, MonoidalAction (..), actHom)-import Proarrow.Category.Monoidal.EndoProf (ENDO (..), Precomp)-import Proarrow.Category.Monoidal.Rev (REV (..))-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), obj, rmap, (//), (:~>), (\\), type (+->))-import Proarrow.Functor (FunctorForRep (..))-import Proarrow.Optic (ExOptic (..))-import Proarrow.Optic.Action (ActFl (..))+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), lmap, rmap, (//), (:~>), (\\), type (+->))+import Proarrow.Optic (Prostrong (..)) import Proarrow.Path   ( Fold   , IsPath@@ -32,8 +29,10 @@   , SPath (..)   , Tag (..)   , appendPath+  , concatFold   , idN   , singPath+  , splitFold   , weakenTight   , whiskerL   , whiskerR@@ -43,21 +42,20 @@   , withObAppend   , type (+++)   )-import Proarrow.Profunctor.Corepresentable (Corep (..), Corepresentable (..)) import Proarrow.Profunctor.Instance.Composition ((:.:) (..)) import Proarrow.Profunctor.Instance.Identity (Id (..))-import Proarrow.Profunctor.Representable (CorepStar (..), Rep (..), Representable (..))+import Proarrow.Profunctor.Representable (Representable (..))  infixl 6 ||| infixl 5 ===  -- | The kind of a square @p q f g@. ----- > h--f--i--- > |  v  |--- > p--@--q--- > |  v  |--- > j--g--k+-- > h---p---j+-- > |   |   |+-- > f>--@-->g+-- > |   |   |+-- > i---q---k type Sq :: Path j h -> Path k i -> Path h i -> Path j k -> Type data Sq p q f g where   Sq@@ -65,179 +63,234 @@     => Fold (p +++ f) :~> Fold (g +++ q)     -> Sq p q f g +-- | Construct a square from its pointwise action. The representable legs act on the+-- input objects through '%'; composition and identity wrappers on those legs are handled+-- automatically. The action must be natural in both objects.+--+-- A traversal crossing, with @[]@ effects and @Maybe@ data:+--+-- >>> import Proarrow.Profunctor.Instance.Star (Star, pattern Star, unStar)+-- >>> import Prelude qualified as P+-- >>> type Crossing = Sq (Star [] ::: Nil) (Star [] ::: Nil) (Star P.Maybe ::: Nil) (Star P.Maybe ::: Nil)+-- >>> let crossing = mkSquare (\(Star f) -> Star (P.traverse f)) :: Crossing+-- >>> unStar (runSquare crossing (Star (\x -> [x, P.not x]))) (P.Just P.True)+-- [Just True,Just False]+-- >>> unStar (runSquare crossing (Star (\x -> [x, P.not x]))) P.Nothing+-- [Nothing]+mkSquare+  :: forall ps qs fs gs+   . (IsPath ps, IsPath qs, IsTight fs, IsTight gs)+  => (forall a b. (Ob a, Ob b) => Fold ps a b -> Fold qs (Fold fs % a) (Fold gs % b))+  -> Sq ps qs fs gs+mkSquare n =+  withFoldOb sps $+    withFoldOb sqs $+      withFoldRep tfs $+        withFoldRep tgs $+          Sq \pf -> case splitFold sps sfs pf of+            f :.: p -> p // concatFold sgs sqs (lmap (index f) (n p) :.: repUniv @(Fold gs))+  where+    sps :: SPath Prof ps+    sps = singPath+    sqs :: SPath Prof qs+    sqs = singPath+    tfs :: SPath Tight fs+    tfs = singPath+    tgs :: SPath Tight gs+    tgs = singPath+    sfs = weakenTight tfs+    sgs = weakenTight tgs++-- | Evaluate a square on a profunctor value. Inverse to 'mkSquare', by naturality and+-- the representability laws. Empty profunctor paths still use the 'Id' wrapper.+runSquare+  :: forall ps qs fs gs a b+   . Sq ps qs fs gs+  -> Fold ps a b+  -> Fold qs (Fold fs % a) (Fold gs % b)+runSquare (Sq n) p =+  withFoldOb sps $+    withFoldOb sqs $+      withFoldRep tfs $+        withFoldRep tgs $+          p // case splitFold sgs sqs (n (concatFold sps sfs (repUniv @(Fold fs) :.: p))) of+            q :.: g -> rmap (index g) q+  where+    sps :: SPath Prof ps+    sps = singPath+    sqs :: SPath Prof qs+    sqs = singPath+    tfs :: SPath Tight fs+    tfs = singPath+    tgs :: SPath Tight gs+    tgs = singPath+    sfs = weakenTight tfs+    sgs = weakenTight tgs+ -- | The empty square for an object. ----- > K-----K--- > |     |--- > |     |--- > |     |--- > K-----K+-- > K-------K+-- > |       |+-- > |       |+-- > |       |+-- > K-------K object :: (CategoryOf k) => Sq (Nil :: Path k k) Nil Nil Nil object = Sq idN --- | Make a square from a horizontal proarrow.+-- | A square between profunctors, with trivial representable legs. ----- > K-----K--- > |     |--- > p--@--q--- > |     |--- > J-----J-hArr :: (Profunctor p, Profunctor q) => p :~> q -> Sq (p ::: Nil) (q ::: Nil) Nil Nil-hArr = Sq+-- > K---p---J+-- > |   |   |+-- > |   @   |+-- > |   |   |+-- > K---q---J+vArr :: (Profunctor p, Profunctor q) => p :~> q -> Sq (p ::: Nil) (q ::: Nil) Nil Nil+vArr = Sq --- | A horizontal identity square.+-- | A vertical identity square. ----- > J-----J--- > |     |--- > p-----p--- > |     |--- > K-----K-hId :: (Profunctor p) => Sq (p ::: Nil) (p ::: Nil) Nil Nil-hId = hArr idN+-- > J---p---K+-- > |   |   |+-- > |   |   |+-- > |   |   |+-- > J---p---K+vId :: (Profunctor p) => Sq (p ::: Nil) (p ::: Nil) Nil Nil+vId = vArr idN --- | Make a square from a vertical arrow.+-- | A square between representable profunctors, with trivial profunctor legs. ----- > J--f--K--- > |  v  |--- > |  @  |--- > |  v  |--- > J--g--K-vArr :: (Representable f, Representable g) => f :~> g -> Sq Nil Nil (f ::: Nil) (g ::: Nil)-vArr = Sq+-- > J-------J+-- > |       |+-- > f>--@-->g+-- > |       |+-- > K-------K+hArr :: (Representable f, Representable g) => f :~> g -> Sq Nil Nil (f ::: Nil) (g ::: Nil)+hArr = Sq --- | A vertical identity square.+-- | A horizontal identity square. ----- > J--f--K--- > |  v  |--- > |  |  |--- > |  v  |--- > J--f--K-vId :: (Representable f) => Sq Nil Nil (f ::: Nil) (f ::: Nil)-vId = vArr idN+-- > J-------J+-- > |       |+-- > f>----->f+-- > |       |+-- > K-------K+hId :: (Representable f) => Sq Nil Nil (f ::: Nil) (f ::: Nil)+hId = hArr idN --- | Horizontal composition.+-- | Horizontal composition, with the left square first. Profunctor paths concatenate+-- from right to left, matching the order of profunctor composition. ----- > L--d--H     H--f--I     L-d+f-I--- > |  v  |     |  v  |     |  v  |--- > p--@--q ||| q--@--r  =  p--@--r--- > |  v  |     |  v  |     |  v  |--- > M--e--J     J--g--K     M-e+g-K-(|||) :: forall ps qs rs ds es fs gs. Sq ps qs ds es -> Sq qs rs fs gs -> Sq ps rs (ds +++ fs) (es +++ gs)+-- > H--p--L--r--M       H--r+p--M+-- > |     |     |       |       |+-- > f--@--g--@--e   =   f---@---e+-- > |     |     |       |       |+-- > I--q--J--s--K       I--s+q--K+(|||) :: forall ps qs fs gs rs ss es. Sq ps qs fs gs -> Sq rs ss gs es -> Sq (rs +++ ps) (ss +++ qs) fs es Sq l ||| Sq r =-  withObAppend @Tight @ds @fs tds $-    withObAppend @Tight @es @gs tes $-      withAssoc @ps @ds @fs @Prof $-        withAssoc @es @qs @fs @Tight $-          withAssoc @es @gs @rs @Tight $+  withObAppend @Prof @rs @ps srs $+    withObAppend @Prof @ss @qs sss $+      withAssoc @es @ss @qs @Tight $+        withAssoc @rs @ps @fs @Prof $+          withAssoc @rs @gs @qs @Prof $             Sq $-              whiskerL ses (appendPath sqs sfs) (appendPath sgs srs) r-                . whiskerR (appendPath sps sds) (appendPath ses sqs) sfs l+              whiskerR (appendPath srs sgs) (appendPath ses sss) sqs r+                . whiskerL srs (appendPath sps sfs) (appendPath sgs sqs) l   where-    tds :: SPath Tight ds-    tds = singPath-    tes :: SPath Tight es-    tes = singPath+    srs :: SPath Prof rs+    srs = singPath+    sss :: SPath Prof ss+    sss = singPath     sps :: SPath Prof ps     sps = singPath     sqs :: SPath Prof qs     sqs = singPath-    srs :: SPath Prof rs-    srs = singPath-    sds :: SPath Prof ds-    sds = weakenTight tds-    ses :: SPath Prof es-    ses = weakenTight tes     sfs :: SPath Prof fs     sfs = weakenTight singPath     sgs :: SPath Prof gs     sgs = weakenTight singPath+    ses :: SPath Prof es+    ses = weakenTight singPath --- | Vertical composition.+-- | Vertical composition, with the top square first. ----- >  H--e--I--- >  |  v  |--- >  r--@--s--- >  |  v  |--- >  J--f--K--- >    ===--- >  J--f--K--- >  |  v  |--- >  p--@--q--- >  |  v  |--- >  L--g--M--- >--- >    v v--- >--- >  H--e--I--- >  |  v  |--- > p+r-@-q+s--- >  |  v  |--- >  J--g--K-(===) :: forall rs ss es fs ps qs gs. Sq rs ss es fs -> Sq ps qs fs gs -> Sq (ps +++ rs) (qs +++ ss) es gs+-- > L---p---M       L---p---M+-- > |       |       |       |+-- > d---@---e       |       |+-- > |       |       |       |+-- > H---q---J   =  d+f--@--e+g+-- > |       |       |       |+-- > f---@---g       |       |+-- > |       |       |       |+-- > I---r---K       I---r---K+(===) :: forall ps qs rs ds es fs gs. Sq ps qs ds es -> Sq qs rs fs gs -> Sq ps rs (ds +++ fs) (es +++ gs) Sq top === Sq bot =-  withObAppend @Prof @ps @rs sps $-    withObAppend @Prof @qs @ss sqs $-      withAssoc @gs @qs @ss @Tight $-        withAssoc @ps @rs @es @Prof $-          withAssoc @ps @fs @ss @Prof $+  withObAppend @Tight @ds @fs tds $+    withObAppend @Tight @es @gs tes $+      withAssoc @ps @ds @fs @Prof $+        withAssoc @es @qs @fs @Tight $+          withAssoc @es @gs @rs @Tight $             Sq $-              whiskerR (appendPath sps sfs) (appendPath sgs sqs) sss bot-                . whiskerL sps (appendPath srs ses) (appendPath sfs sss) top+              whiskerL ses (appendPath sqs sfs) (appendPath sgs srs) bot+                . whiskerR (appendPath sps sds) (appendPath ses sqs) sfs top   where+    tds :: SPath Tight ds+    tds = singPath+    tes :: SPath Tight es+    tes = singPath     sps :: SPath Prof ps     sps = singPath     sqs :: SPath Prof qs     sqs = singPath     srs :: SPath Prof rs     srs = singPath-    sss :: SPath Prof ss-    sss = singPath+    sds :: SPath Prof ds+    sds = weakenTight tds     ses :: SPath Prof es-    ses = weakenTight singPath+    ses = weakenTight tes     sfs :: SPath Prof fs     sfs = weakenTight singPath     sgs :: SPath Prof gs     sgs = weakenTight singPath --- | Bend a vertical arrow in the companion direction.+-- | Bend a representable profunctor from the left edge to its companion on the bottom edge. ----- > J--f--K--- > |  v  |--- > |  \->f--- > |     |--- > J-----J-toRight :: (Representable f) => Sq Nil (f ::: Nil) (f ::: Nil) Nil-toRight = Sq idN+-- > J-------J+-- > |       |+-- > f>--\   |+-- > |   v   |+-- > K---f---J+toBottom :: (Representable f) => Sq Nil (f ::: Nil) (f ::: Nil) Nil+toBottom = Sq idN --- | Bend a vertical arrow in the conjoint direction.+-- | Bend a representable profunctor from the left edge to its conjoint on the top edge. ----- > J--f--K--- > |  v  |--- > f<-/  |--- > |     |--- > K-----K-toLeft :: forall f f'. (Proadjunction f f', Representable f) => Sq (f' ::: Nil) Nil (f ::: Nil) Nil-toLeft = Sq (counitNat @f @f')+-- > J---f---K+-- > |   ^   |+-- > f>--/   |+-- > |       |+-- > K-------K+toTop :: forall f f'. (Proadjunction f f', Representable f) => Sq (f' ::: Nil) Nil (f ::: Nil) Nil+toTop = Sq (counitNat @f @f') --- | Bend a companion proarrow back to a vertical arrow.+-- | Bend a companion from the top edge back to a representable profunctor on the right edge. ----- > K-----K--- > |     |--- > f>-\  |--- > |  v  |--- > J--f--K-fromLeft :: (Representable f) => Sq (f ::: Nil) Nil Nil (f ::: Nil)-fromLeft = Sq idN+-- > K---f---J+-- > |   v   |+-- > |   \-->f+-- > |       |+-- > K-------K+fromTop :: (Representable f) => Sq (f ::: Nil) Nil Nil (f ::: Nil)+fromTop = Sq idN --- | Bend a conjoint proarrow back to a vertical arrow.+-- | Bend a conjoint from the bottom edge back to a representable profunctor on the right edge. ----- > J-----J--- > |     |--- > |  /-<f--- > |  v  |--- > J--f--K-fromRight :: forall f f'. (Proadjunction f f', Representable f) => Sq Nil (f' ::: Nil) Nil (f ::: Nil)-fromRight = Sq (unitNat @f @f')+-- > J-------J+-- > |       |+-- > |   /-->f+-- > |   ^   |+-- > J---f---K+fromBottom :: forall f f'. (Proadjunction f f', Representable f) => Sq Nil (f' ::: Nil) Nil (f ::: Nil)+fromBottom = Sq (unitNat @f @f')  unitNat :: forall p q. (Proadjunction p q) => Id :~> q :.: p unitNat (Id f) = rmap f (Adj.unit @p @q) \\ f@@ -245,86 +298,118 @@ counitNat :: forall p q. (Proadjunction p q) => p :.: q :~> Id counitNat pq = Id (Adj.counit pq) --- > K--I--K--- > |  v  |--- > |  @  |--- > |     |--- > K-----K-vUnitor :: forall k. (CategoryOf k) => Sq Nil Nil ((Id :: CAT k) ::: Nil) Nil-vUnitor = vSplitAll @Nil+-- > K-------K+-- > |       |+-- > I>--@   |+-- > |       |+-- > K-------K+hUnitor :: forall k. (CategoryOf k) => Sq Nil Nil ((Id :: CAT k) ::: Nil) Nil+hUnitor = hSplitAll @Nil --- > K-----K--- > |     |--- > |  @  |--- > |  v  |--- > K--I--K-vUnitorInv :: forall k. (CategoryOf k) => Sq Nil Nil Nil ((Id :: CAT k) ::: Nil)-vUnitorInv = vCombineAll @Nil+-- > K-------K+-- > |       |+-- > |   @-->I+-- > |       |+-- > K-------K+hUnitorInv :: forall k. (CategoryOf k) => Sq Nil Nil Nil ((Id :: CAT k) ::: Nil)+hUnitorInv = hCombineAll @Nil --- > I-f-g-K--- > | v v |--- > | \@/ |--- > |  v  |--- > I-gof-K-vCombine :: forall p q. (Representable p, Representable q) => Sq Nil Nil (p ::: q ::: Nil) (q :.: p ::: Nil)-vCombine = vCombineAll @(p ::: q ::: Nil)+-- > I---------I+-- > f>---\    |+-- > |    @->gof+-- > g>---/    |+-- > K---------K+hCombine :: forall f g. (Representable f, Representable g) => Sq Nil Nil (f ::: g ::: Nil) (g :.: f ::: Nil)+hCombine = hCombineAll @(f ::: g ::: Nil) --- > I-gof-K--- > |  v  |--- > | /@\ |--- > | v v |--- > I-f-g-K-vSplit :: forall p q. (Representable p, Representable q) => Sq Nil Nil (q :.: p ::: Nil) (p ::: q ::: Nil)-vSplit = vSplitAll @(p ::: q ::: Nil)+-- > I---------I+-- > |    /--->f+-- > gof>-@    |+-- > |    \--->g+-- > K---------K+hSplit :: forall f g. (Representable f, Representable g) => Sq Nil Nil (g :.: f ::: Nil) (f ::: g ::: Nil)+hSplit = hSplitAll @(f ::: g ::: Nil) --- | Combine a whole bunch of vertical arrows into one composed arrow.+-- | Combine a path of representable profunctors into one composed representable profunctor. ----- > J-p..-K--- > | vvv |--- > | \@/ |--- > |  v  |--- > J--f--K-vCombineAll :: forall ps. (IsTight ps) => Sq Nil Nil ps (Fold ps ::: Nil)-vCombineAll = withFoldRep tp (Sq idN)+-- > J---------J+-- > f>---\    |+-- > |    @--->F+-- > g>---/    |+-- > K---------K+hCombineAll :: forall fs. (IsTight fs) => Sq Nil Nil fs (Fold fs ::: Nil)+hCombineAll = withFoldRep tfs (Sq idN)   where-    tp :: SPath Tight ps-    tp = singPath+    tfs :: SPath Tight fs+    tfs = singPath --- | Split one composed arrow into a whole bunch of vertical arrows.+-- | Split one composed representable profunctor into a path of representable profunctors. ----- > J--f--K--- > |  v  |--- > | /@\ |--- > | vvv |--- > J-p..-K-vSplitAll :: forall ps. (IsTight ps) => Sq Nil Nil (Fold ps ::: Nil) ps-vSplitAll = withFoldRep tp (Sq idN)+-- > J---------J+-- > |    /--->f+-- > F>---@    |+-- > |    \--->g+-- > K---------K+hSplitAll :: forall fs. (IsTight fs) => Sq Nil Nil (Fold fs ::: Nil) fs+hSplitAll = withFoldRep tfs (Sq idN)   where-    tp :: SPath Tight ps-    tp = singPath+    tfs :: SPath Tight fs+    tfs = singPath --- | Combine a whole bunch of horizontal proarrows into one composed proarrow.+-- > K---I---K+-- > |   |   |+-- > |   @   |+-- > |       |+-- > K-------K+vUnitor :: forall k. (CategoryOf k) => Sq ((Id :: CAT k) ::: Nil) Nil Nil Nil+vUnitor = vSplitAll @Nil++-- > K-------K+-- > |       |+-- > |   @   |+-- > |   |   |+-- > K---I---K+vUnitorInv :: forall k. (CategoryOf k) => Sq Nil ((Id :: CAT k) ::: Nil) Nil Nil+vUnitorInv = vCombineAll @Nil++-- > K-q---p-J+-- > |  \ /  |+-- > |   @   |+-- > |   |   |+-- > K--qop--J+vCombine :: forall p q. (Profunctor p, Profunctor q) => Sq (p ::: q ::: Nil) (q :.: p ::: Nil) Nil Nil+vCombine = vCombineAll @(p ::: q ::: Nil)++-- > K--qop--J+-- > |   |   |+-- > |   @   |+-- > |  / \  |+-- > K-q---p-J+vSplit :: forall p q. (Profunctor p, Profunctor q) => Sq (q :.: p ::: Nil) (p ::: q ::: Nil) Nil Nil+vSplit = vSplitAll @(p ::: q ::: Nil)++-- | Combine a path of profunctors into one composed profunctor. ----- > K-----K--- > p--\  |--- > :--@--F--- > :--/  |--- > J-----J-hCombineAll :: forall ps. (IsPath ps) => Sq ps (Fold ps ::: Nil) Nil Nil-hCombineAll = withFoldOb sp (Sq idN)+-- > K-q---p-J+-- > |  \ /  |+-- > |   @   |+-- > |   |   |+-- > K---F---J+vCombineAll :: forall ps. (IsPath ps) => Sq ps (Fold ps ::: Nil) Nil Nil+vCombineAll = withFoldOb sp (Sq idN)   where     sp :: SPath Prof ps     sp = singPath --- | Split one composed proarrow into a whole bunch of horizontal proarrows.+-- | Split one composed profunctor into a path of profunctors. ----- > K-----K--- > |  /--p--- > F--@--:--- > |  \--:--- > J-----J-hSplitAll :: forall ps. (IsPath ps) => Sq (Fold ps ::: Nil) ps Nil Nil-hSplitAll = withFoldOb sp (Sq idN)+-- > K---F---J+-- > |   |   |+-- > |   @   |+-- > |  / \  |+-- > K-q---p-J+vSplitAll :: forall ps. (IsPath ps) => Sq (Fold ps ::: Nil) ps Nil Nil+vSplitAll = withFoldOb sp (Sq idN)   where     sp :: SPath Prof ps     sp = singPath@@ -332,75 +417,83 @@ -- | The unit of an adjunction. -- -- > J-------J--- > |   /---q--- > |   @   |--- > |   \---p--- > J-------J+-- > |       |+-- > | /-@-\ |+-- > | |   | |+-- > J-q---p-J unit :: forall p q. (Proadjunction p q) => Sq Nil (p ::: q ::: Nil) Nil Nil-unit = hCombineAll @Nil ||| hArr (unitNat @p @q) ||| hSplitAll @(p ::: q ::: Nil)+unit =+  vCombineAll @Nil+    === vArr (unitNat @p @q)+    === vSplitAll @(p ::: q ::: Nil)  -- | The counit of an adjunction. ----- > K-------K--- > p---\   |--- > |   @   |--- > q---/   |+-- > K-p---q-K+-- > | |   | |+-- > | \-@-/ |+-- > |       | -- > K-------K counit :: forall p q. (Proadjunction p q) => Sq (q ::: p ::: Nil) Nil Nil Nil-counit = hCombineAll @(q ::: p ::: Nil) ||| hArr (counitNat @p @q) ||| hSplitAll @Nil+counit =+  vCombineAll @(q ::: p ::: Nil)+    === vArr (counitNat @p @q)+    === vSplitAll @Nil --- | Optics in the @Prof@ equipment.+-- | A square introducing an effect @r@ between representable data shapes @f@ and @g@,+-- with no incoming effect. Optics consume and produce squares of this same shape. ----- > J-------J--- > s>--@-->a--- > |   @   |--- > t<--@--<b--- > K-------K-type EqpOptic a b s t = (IsOptic a b s t) => Sq (t ::: s ::: Nil) (b ::: a ::: Nil) Nil Nil--type IsOptic a b s t = (Representable s, Corepresentable t, Representable a, Corepresentable b)--mkOptic-  :: (IsOptic a b s t)-  => (forall x r. (Ob x) => (forall y. (Ob y) => (s % x ~> a % y) -> (b %% y ~> t %% x) -> r) -> r)-  -> EqpOptic a b s t-mkOptic k = Sq \((:.:) @x s t) -> s // k @x \ @y get put -> tabulate @_ @y (get . index s) :.: cotabulate (coindex t . put)---- | Sequential composition of optics, with 2 holes.-seq-  :: forall a b s t a' b' u v-   . (Proadjunction u t, IsOptic a b s t, IsOptic a' b' u v)-  => EqpOptic a b s t -> EqpOptic a' b' u v -> Sq (v ::: s ::: Nil) (b' ::: a' ::: b ::: a ::: Nil) Nil Nil-seq st uv = (hId @s === unit @u @t === hId @v) ||| (st === uv)--data family Action :: (m, k) +-> k -> k -> m +-> k-instance (MonoidalAction act, Ob a) => FunctorForRep (Action act a :: m +-> k) where-  type Action act a @ x = Act act x a-  fmap f = actHom @act f (obj @a)--type ActionOptic act a b s t =-  EqpOptic (Rep (Action act a)) (Corep (Action act b)) (Rep (Action act s)) (Corep (Action act t))--fromOptic :: (MonoidalAction act, Ob a, Ob b, Ob s, Ob t) => ExOptic (ActFl act) a b s t -> ActionOptic act a b s t-fromOptic @act @a @b @s @t (ExOptic (l :: p s a) (r :: q b t)) = mkOptic \ @x k ->-  withActP @act @p @q l r \ @z f g ->-    withOb2 @_ @x @z $-      k @(x ** z)-        (multiplicatorInv @act @x @z @a . actHom @act (obj @x) f)-        (actHom @act (obj @x) g . multiplicator @act @x @z @b)+-- > X-----------X+-- > |           |+-- > f>----@---->g+-- > |     |     |+-- > J-----r-----K+type InputSquare :: (k +-> j) -> (x +-> j) -> (x +-> k) -> Type+type InputSquare r f g = Sq Nil (r ::: Nil) (f ::: Nil) (g ::: Nil) -toOptic-  :: forall h x (s :: x +-> h) (t :: h +-> x) (a :: x +-> h) (b :: h +-> x)-   . (CategoryOf h, CategoryOf x, Representable s, Corepresentable t, Representable a, Corepresentable b)-  => EqpOptic a b s t-  -> ExOptic (ActFl (Rep Precomp)) a (CorepStar b) s (CorepStar t)-toOptic (Sq pl) =-  ExOptic-    (Rep @a @(ActionAt (Rep Precomp) (R (E (b :.: CorepStar t)))) (P.Prof get))-    (Corep @(CorepStar b) @(ActionAt (Rep Precomp) (R (E (b :.: CorepStar t)))) (P.Prof put))-  where-    get :: s :~> a :.: (b :.: CorepStar t)-    get s = s // case Adj.unit @(CorepStar t) @t of t :.: t' -> case pl (s :.: t) of a :.: b -> a :.: (b :.: t')+-- | Absorb a general witness pair around an effect with 'proact'. All three incoming+-- profunctors are vertical or diagonal wires. No representability is required of @p@ or @q@.+--+-- > J--p--r--q--K+-- > |   \ | /   |+-- > |    @@@    |+-- > |     |     |+-- > J-----r-----K+proSquare+  :: forall {j} {k} w (r :: k +-> j) (p :: j +-> j) (q :: k +-> k)+   . (Prostrong w r, w p q, Profunctor p, Profunctor q)+  => Sq (q ::: r ::: p ::: Nil) (r ::: Nil) Nil Nil+proSquare =+  vCombineAll @(q ::: r ::: p ::: Nil)+    === vArr (proact @w @r @p @q) -    put :: CorepStar b :.: (b :.: CorepStar t) :~> CorepStar t-    put (b' :.: (b :.: t')) = lmap (Adj.counit @(CorepStar b) @b (b' :.: b)) t'+-- | An optic between representable data shapes, programmed by composing squares.+-- Its legs @s :~> p :.: a@ and @b :~> q :.: t@ introduce the residual profunctors+-- @p@ and @q@, which are absorbed with the input effect by 'proSquare'. All four+-- data shapes share an index category. Constant shapes from the terminal category+-- recover optics between individual objects.+--+-- Wire names appear on borders; each contiguous run of @\@@ marks one transformation. The top central+-- square is the input, the left square unpacks, and the right square rebuilds. The+-- lower square absorbs their three outgoing effects. Residual profunctors stay+-- vertical or diagonal; only representable data wires run horizontally:+--+-- > X-----+-----+-----X+-- > |     |     |     |+-- > s>-@->a>-@->b>-@->t+-- > |  |  |  |  |  |  |+-- > +--p--+--r--+--q--++-- > |   \    |    /   |+-- > |    @@@@@@@@@    |+-- > |        |        |+-- > J--------r--------K+--+-- The outer boundary is another input-shaped square, now with data legs @s@ and @t@,+-- so it can be used as the input to another optic.+opticSquare+  :: forall {j} {k} {x} w (r :: k +-> j) (p :: j +-> j) (q :: k +-> k) (s :: x +-> j) (t :: x +-> k) (a :: x +-> j) (b :: x +-> k)+   . (Prostrong w r, w p q, Profunctor p, Profunctor q)+  => InputSquare p s a -> InputSquare q b t -> InputSquare r a b -> InputSquare r s t+opticSquare unpack rebuild input =+  unpack ||| input ||| rebuild+    === proSquare @w
src/Proarrow/Tools/CCC.hs view
@@ -1,31 +1,76 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{- HLINT ignore "Redundant $" -}---- | A small HOAS (higher-order abstract syntax) front end for building morphisms in any--- 'BiCCC', compiling through the free category of "Proarrow.Category.Instance.Free" with the--- bicartesian closed structures rather than a bespoke one. A 'Free' term tracks its free--- variables via a context list, the way a well-scoped lambda calculus does; 'lam' binds an--- ordinary Haskell-level variable that 'Cast' automatically "weakens" across nested lambdas so--- inner lambdas can still refer to outer ones. 'toCCC' interprets a closed term (no free--- variables) into an actual morphism of the target category.+-- | Cartesian terms, using the syntax and binders of "Proarrow.Tools.SMC" in 'PROD' @k@.+-- Its tensor is the product of @k@, independently of any monoidal structure on @k@ itself.+-- 'F' embeds a base object, @a ':**' b@ is a product, and @a ':->' b@ is the exponential+-- of 'PROD' @k@. 'toCCC' compiles a function on terms and unwraps the resulting arrow into @k@.+--+-- Each operation asks only for the structure it uses: products for pairing and binding,+-- 'Closed' @('PROD' k)@ for 'lam' and '(!)', coproducts for 'inl' and 'inr', and+-- 'Proarrow.Category.Monoidal.Distributive.Distributive' @('PROD' k)@ for 'caseOf'. Copying and+-- discarding are supplied by products. The patterns, contexts and @QualifiedDo@ notation are+-- those of SMC; see "Proarrow.Tools.SMC" for their use, including 'recast' across binding depths.+--+-- > import Prelude hiding ((**))+-- > import Proarrow.Tools.CCC (SYN (..), type F, toCCC, (**))+-- >+-- > swapProduct = toCCC @(F a :** F b) @(F b :** F a) (\(a, b) -> b ** a) module Proarrow.Tools.CCC-  ( toCCC-  , lam-  , ($)+  ( -- * Types+    SYN (I, (:**), (:->), (:&&), Top, (:||), Zero)+  , type F+  , Interp+  , KnownObj++    -- * Terms++    -- ** Products+  , Term+  , toCCC+  , toCCC1   , lift-  , pattern (:&)-  , either-  , lft-  , rgt-  , Free-  , Syntax+  , liftF+  , (-<)+  , returnA+  , unit+  , (**)+  , split+  , Tuple+  , TupleCtx+  , recast+  , with+  , exl+  , exr+  , absorb++    -- ** Product exponentials+  , lam+  , Apply (..)++    -- ** Coproducts+  , inl+  , inr+  , caseOf+  , ifThenElse+  , Sum+  , absurd++    -- * Contexts   , Ctx-  , Mul-  , Cast (..)-  , KnownCtx (..)-  , BiCCCStructs-  , type F+  , KnownCtx+  , Union+  , Merge+  , Thin+  , BindVar++    -- * Do notation+  , (>>=)+  , return+  , fail+  , Bind+  , Binds++    -- * Examples   , injectRight   , swapProduct   , applyPair@@ -35,252 +80,156 @@   , caseEither   ) where -import Data.Kind (Constraint)-import Prelude (type (~))--import Proarrow.Category.Instance.Free (FREE (..), Lower, emb, fold)-import Proarrow.Category.Monoidal (Monoidal)-import Proarrow.Category.Monoidal.Cartesian (BiCCC, Cartesian, prodToTensor, tensorToProd, unitToTerm)-import Proarrow.Category.Monoidal.Closed (Closed (..), lower)-import Proarrow.Category.Monoidal.Distributive (Distributive (..))-import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts ((+++), (|||)), type (||))-import Proarrow.Colimit.BinaryCoproduct qualified as BC-import Proarrow.Colimit.Initial (HasInitialObject)-import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..))-import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..), type (*!))-import Proarrow.Limit.Terminal (HasTerminalObject, TermF)-import Proarrow.Object (Obj)-import Proarrow.Profunctor.Instance.Identity (Id (..))--infixr 0 $---- | The structures of a bicartesian closed category as a list for 'FREE': the five BiCCC--- classes, the 'Cartesian' marker supplying the formal @tensor = product@ coercions (the free--- category cannot state that type equality itself), and 'Distributive', for case analysis in the--- presence of a context.-type BiCCCStructs =-  '[ HasTerminalObject-   , HasInitialObject-   , HasBinaryProducts-   , HasBinaryCoproducts-   , Monoidal-   , Closed-   , Cartesian-   , Distributive-   ]---- | The syntax category over @k@: the free BiCCC on @k@'s own hom-sets, i.e. 'Id'. @(~>)@ itself--- is an unsaturated type family application, so it isn't allowed as a type index where it is--- pattern-matched on below, in 'Mul'.-type Syntax k = FREE BiCCCStructs (Id :: CAT k)--type Ctx k = [Syntax k]---- | A short alias for embedding a base-category object, so type applications built from it read--- like the target signature: '&&', '||' and '~~>' on the free category are its object formers,--- so @(F a ~~> F b) && F a@ is the object it looks like.-type F a = EMB a---- | The context product: @'Mul' i@ is the single object standing in for "all the bound--- variables in @i@", a right fold with the most-recently-bound variable last. This mirrors--- "Proarrow.Category.Monoidal.Strictified"'s @Fold@, which puts its head leftmost. @Fold@ itself--- can't be reused, since 'curry'\/'fst'\/'snd' expect the thing being abstracted over on the right--- of the product.-type family Mul (i :: Ctx k) :: Syntax k where-  Mul '[] = TermF-  Mul (a ': as) = Mul as *! a---- | A term with free variables @i@ (innermost\/most-recently-bound first) and result type--- @a@: a morphism from the context product to @a@ in the free BiCCC. A newtype--- (rather than a bare type synonym) so that @i@ is recoverable from a 'Free' term's type: 'Mul'--- is many-to-one at the type-family level as far as GHC's injectivity checker is concerned (even--- though it's mathematically injective here), which would otherwise leave @i@ ambiguous wherever--- it has to be inferred rather than given explicitly (e.g. picking which context a HOAS variable--- reference in 'lam' denotes).-newtype Free (i :: Ctx k) (a :: Syntax k) = MkFree {unFree :: Mul i ~> a}--type KnownCtx :: forall {k}. Ctx k -> Constraint-class KnownCtx (i :: Ctx k) where-  ctxOb :: Obj (Mul i)--instance KnownCtx ('[] :: Ctx k) where-  ctxOb = id--instance (KnownCtx i, Ob (b :: Syntax k)) => KnownCtx (b ': i) where-  ctxOb = id \\ ctxOb @i---- | The most-recently-bound variable.-headT :: forall {k} a i. (KnownCtx (i :: Ctx k), Ob (a :: Syntax k)) => Free (a ': i) a-headT = MkFree (snd @(Syntax k) @(Mul i) @a) \\ ctxOb @i---- | Weaken a term by one more bound variable it doesn't use.-tailT :: forall {k} a i b. (KnownCtx (i :: Ctx k), Ob (a :: Syntax k)) => Free i b -> Free (a ': i) b-tailT (MkFree f) = MkFree (f . fst @(Syntax k) @(Mul i) @a) \\ ctxOb @i---- | @'Cast' i j@ holds when context @i@ is context @j@ with zero or more extra variables--- pushed on top, letting a term built for @j@ be used anywhere \"deeper\" than @j@.-type Cast :: forall {k}. Ctx k -> Ctx k -> Constraint-class Cast (i :: Ctx k) (j :: Ctx k) where-  cast :: (Ob (a :: Syntax k)) => Free j a -> Free i a--instance Cast i i where-  cast f = f--instance-  {-# OVERLAPPABLE #-}-  (Cast i j, KnownCtx (i :: Ctx k), Ob (b :: Syntax k), (b ': i) ~ i')-  => Cast i' j-  where-  cast f = tailT (cast f)---- | Bind a variable, HOAS-style: the function argument stands for the newly bound variable,--- usable (via 'Cast') in the body of this 'lam' and any 'lam' nested inside it. The body is a--- morphism out of the context product, but 'curry' wants the tensor, so the 'Cartesian'--- coercion mediates.-lam-  :: forall {k} a b i-   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)-  => ((forall (x :: Ctx k). (Cast x (a ': i)) => Free x a) -> Free (a ': i) b)-  -> Free i (a ~~> b)-lam f = MkFree (curry @(Syntax k) @(Mul i) @a @b (unFree (f xa) . tensorToProd @(Mul i) @a)) \\ ctxOb @i-  where-    xa :: forall (x :: Ctx k). (Cast x (a ': i)) => Free x a-    xa = cast (headT @a @i)---- | Function application.-($) :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i (a ~~> b) -> Free i a -> Free i b-MkFree f $ MkFree g = MkFree (apply @(Syntax k) @a @b . prodToTensor @(a ~~> b) @a . (f &&& g))---- | Embed a morphism of the target category as a term between embedded objects.-lift :: forall {k} a b i. (Ob (a :: k), Ob b) => a ~> b -> Free i (F a) -> Free i (F b)-lift f (MkFree g) = MkFree (emb (Id f) . g)--fstSnd :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i (a && b) -> (Free i a, Free i b)-fstSnd (MkFree f) = (MkFree (fst @(Syntax k) @a @b . f), MkFree (snd @(Syntax k) @a @b . f))--pattern (:&) :: (Ob (a :: Syntax k), Ob b) => Free i a -> Free i b -> Free i (a && b)-pattern x :& y <- (fstSnd -> (x, y))-  where-    x :& y = MkFree (unFree x &&& unFree y)+import Proarrow.Category.Monoidal.Cartesian ()+import Proarrow.Category.Monoidal.Closed (Closed (..))+import Proarrow.Category.Monoidal.Distributive (Distributive)+import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts, type (||))+import Proarrow.Core (CategoryOf (..), Hom, Is, UN)+import Proarrow.Limit.BinaryProduct (HasProducts, PROD (..), Prod (..), type (&&))+import Proarrow.Tools.SMC hiding (F, Interp, lift, liftF, (-<))+import Proarrow.Tools.SMC qualified as SMC+import Prelude (uncurry) -{-# COMPLETE (:&) #-}+-- | A base-category object in the SMC syntax over 'PROD' @k@.+type F :: k -> SYN (PROD k)+type F a = SMC.F (PR a) --- | Inject as the left\/right branch of a sum.-lft :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i a -> Free i (a || b)-lft (MkFree f) = MkFree (BC.lft @(Syntax k) @a @b . f)+-- | The base-category object a cartesian type expression stands for.+type Interp :: SYN (PROD k) -> k+type Interp a = UN PR (SMC.Interp a) -rgt :: forall {k} a b i. (Ob (a :: Syntax k), Ob b) => Free i b -> Free i (a || b)-rgt (MkFree f) = MkFree (BC.rgt @(Syntax k) @a @b . f)+-- | Compile a function on terms into an arrow of @k@. The input arrives through an SMC pattern,+-- a variable, @()@, or a tuple, and the body's operations determine the additional structure needed.+{-# INLINE toCCC #-}+toCCC+  :: forall {k} (a :: SYN (PROD k)) b t cont+   . (HasProducts k, Binds (~>) 0 '[] a b t cont)+  => (t -> cont) -> Interp a ~> Interp b+toCCC f = case SMC.toSMC @a @b f of Prod g -> g --- | Uncurry a function term into the body of a 'lam' binding its argument.-uncurryF-  :: forall {k} a b i-   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)-  => Free i (a ~~> b) -> Free (a ': i) b-uncurryF f = MkFree (apply @(Syntax k) @a @b . prodToTensor @(a ~~> b) @a . (unFree (tailT f) &&& unFree (headT @a @i)))+-- | 'toCCC' with both boundary objects embedded by 'F'. The surrounding morphism type+-- determines the input and output objects, so their type applications can be omitted.+-- Use 'toCCC' when a boundary needs other syntax, such as a product or function type.+{-# INLINE toCCC1 #-}+toCCC1+  :: forall {k} (a :: k) b t cont+   . (HasProducts k, Binds (~>) 0 '[] (F a) (F b) t cont)+  => (t -> cont) -> a ~> b+toCCC1 = toCCC @(F a) @(F b) --- | Case analysis on a sum, in the presence of a shared context: distributes the context over--- the sum, so each branch still has access to it. The free category's distributivity is stated--- for the tensor, so the product is coerced to the tensor and back around 'distL'.-caseT-  :: forall {k} a b c i-   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b)-  => Free i (a || b) -> Free (a ': i) c -> Free (b ': i) c -> Free i c-caseT m f g =-  MkFree-    ( (unFree f ||| unFree g)-        . (tensorToProd @(Mul i) @a +++ tensorToProd @(Mul i) @b)-        . distL @(Syntax k) @(Mul i) @a @b-        . prodToTensor @(Mul i) @(a || b)-        . (id &&& unFree m)-    )-    \\ ctxOb @i+-- | Lift a base-category arrow onto terms. The type expressions can be composite, as in SMC's+-- 'Proarrow.Tools.SMC.lift'; use type applications when their interpretations do not determine them.+{-# INLINE lift #-}+lift+  :: forall {k} (a :: SYN (PROD k)) b d g+   . (CategoryOf k, Is PR (SMC.Interp a), Is PR (SMC.Interp b))+  => Interp a ~> Interp b -> Term d g a -> Term d g b+lift f = SMC.lift @a @b (Prod f) -either-  :: forall {k} a b c i-   . (KnownCtx (i :: Ctx k), Ob (a :: Syntax k), Ob b, Ob c)-  => Free i (a ~~> c) -> Free i (b ~~> c) -> Free i (a || b) -> Free i c-either f g m = caseT m (uncurryF f) (uncurryF g)+-- | Lift a base-category arrow onto a term or tuple of terms, embedding its result by 'F'.+-- The result object is inferred from the arrow. Use 'lift' for composite result syntax.+{-# INLINE liftF #-}+liftF+  :: forall {k} (a :: SYN (PROD k)) b t d+   . (CategoryOf k, Is PR (SMC.Interp a), Tuple (Hom (PROD k)) t a)+  => (Interp a ~> b) -> t -> Term d (TupleCtx (PROD k) t) (F b)+liftF f = SMC.liftF @a @(PR b) (Prod f) --- | Interpret a closed term (no free variables) into an actual morphism of the target--- category: move the empty context from the terminal object to the monoidal unit, 'lower' the--- function-valued term (a closed one needs no arguments to uncurry), and 'fold' into @k@ with--- generators interpreted by unwrapping 'Id' (the free category was built over @k@'s own--- hom-sets directly).-toCCC-  :: forall {k} a b-   . (BiCCC k, Ob (a :: Syntax k), Ob b)-  => Free '[] (a ~~> b) -> Lower (Id :: CAT k) a ~> Lower (Id :: CAT k) b-toCCC (MkFree f) = fold @BiCCCStructs @(Id :: CAT k) unId (lower @a @b (f . unitToTerm))+infixr 0 -< --- $--- The examples below exercise 'lam'\/'Cast' (including nested lambdas) and 'toCCC' at--- @k = 'Type'@, where the compiled morphism can be run and its result printed.+-- | Arrow application, mirroring @f -< x@ in Haskell's arrow notation.+-- This is infix 'liftF': the input may be a term or tuple, and the result is embedded by 'F'.+-- The @Arrows@ extension must be disabled, since it reserves this symbol.+{-# INLINE (-<) #-}+(-<)+  :: forall {k} (a :: SYN (PROD k)) b t d+   . (CategoryOf k, Is PR (SMC.Interp a), Tuple (Hom (PROD k)) t a)+  => (Interp a ~> b) -> t -> Term d (TupleCtx (PROD k) t) (F b)+(-<) = liftF @a @b  -- | Inject as the right element of a sum. -- -- >>> import Prelude (Bool (..)) -- >>> injectRight @Bool @Bool True -- Right True-injectRight :: forall {k} (a :: k) b. (BiCCC k, Ob (a :: k), Ob b) => a ~> (b || a)-injectRight = toCCC @(F a) @(F b || F a) (lam (\x -> rgt x))+injectRight+  :: forall {k} (a :: k) b. (HasProducts k, HasBinaryCoproducts k, Ob a, Ob b) => a ~> (b || a)+injectRight = toCCC @(F a) @(F b :|| F a) (\x -> inr x) --- | Swap a product.+-- | Swap a product. Only products are needed. -- -- >>> import Prelude (Bool (..)) -- >>> swapProduct @Bool @Bool (True, False) -- (False,True)-swapProduct :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => (a && b) ~> (b && a)-swapProduct = toCCC @(F a && F b) @(F b && F a) (lam (\p -> let (x :& y) = p in y :& x))+swapProduct+  :: forall {k} (a :: k) b. (HasProducts k, Ob a, Ob b) => (a && b) ~> (b && a)+swapProduct = toCCC @(F a :** F b) @(F b :** F a) (\(x, y) -> y ** x)  -- | Apply a function to an argument, both bundled in a product. -- -- >>> import Prelude (Bool (..), not) -- >>> applyPair @Bool @Bool (not, True) -- False-applyPair :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => ((a ~~> b) && a) ~> b-applyPair = toCCC @((F a ~~> F b) && F a) @(F b) (lam (\p -> let (f :& a) = p in f $ a))+applyPair+  :: forall {k} (a :: k) b+   . (HasProducts k, Closed (PROD k), Ob a, Ob b)+  => Interp ((F a :-> F b) :** F a) ~> b+applyPair = toCCC @((F a :-> F b) :** F a) @(F b) (uncurry (!))  -- | Curry a pairing function. -- -- >>> import Prelude (Bool (..)) -- >>> curryPair @Bool @Bool True False -- (True,False)-curryPair :: forall {k} (a :: k) b. (BiCCC k, Ob a, Ob b) => a ~> (b ~~> (a && b))-curryPair = toCCC @(F a) @(F b ~~> (F a && F b)) (lam (\x -> lam (\y -> x :& y)))+curryPair+  :: forall {k} (a :: k) b+   . (HasProducts k, Closed (PROD k), Ob a, Ob b)+  => a ~> Interp (F b :-> (F a :** F b))+curryPair = toCCC @(F a) @(F b :-> (F a :** F b)) (\x -> lam (\y -> x ** y)) --- | Flip the argument order of a 3-argument curried function, applying the last argument--- twice. This exercises three levels of nested 'lam' and 'Cast' weakening across all of them.+-- | Flip the first two arguments of a curried function, supplying its third argument from the+-- second as well. Nested binders and a repeated variable use SMC's contexts. -- -- >>> import Prelude (Bool (..)) -- >>> flipCurried3 @Bool @Bool @Bool (\_ a _ -> a) True False -- True flipCurried3-  :: forall {k} a b c. (BiCCC k, Ob (a :: k), Ob b, Ob c) => (b ~~> a ~~> b ~~> c) ~> (a ~~> b ~~> c)+  :: forall {k} (a :: k) b c+   . (HasProducts k, Closed (PROD k), Ob a, Ob b, Ob c)+  => Interp (F b :-> F a :-> F b :-> F c) ~> Interp (F a :-> F b :-> F c) flipCurried3 =-  toCCC @(F b ~~> (F a ~~> (F b ~~> F c))) @(F a ~~> (F b ~~> F c))-    (lam (\x -> lam (\y -> lam (\z -> ((x $ z) $ y) $ z))))+  toCCC @(F b :-> F a :-> F b :-> F c) @(F a :-> F b :-> F c)+    (\x -> lam (\y -> lam (\z -> x ! z ! y ! z))) --- | Swap a sum, via 'either'.+-- | Swap a sum by case analysis. No exponentials are needed. -- -- >>> import Prelude (Bool (..), Either (..)) -- >>> swapSum @Bool @Bool (Left True) -- Right True -- >>> swapSum @Bool @Bool (Right False) -- Left False-swapSum :: forall {k} a b. (BiCCC k, Ob (a :: k), Ob b) => (a || b) ~> (b || a)-swapSum = toCCC @(F a || F b) @(F b || F a) (lam (\x -> either (lam (\y -> rgt y)) (lam (\y -> lft y)) x))+swapSum+  :: forall {k} (a :: k) b+   . (HasProducts k, Distributive (PROD k), Ob a, Ob b)+  => (a || b) ~> (b || a)+swapSum = toCCC @(F a :|| F b) @(F b :|| F a) (\x -> caseOf x inr inl) --- | Eliminate a sum by applying whichever of the two functions matches the branch actually--- present.+-- | Apply whichever function matches the branch of a sum. The functions are shared with the+-- selected branch through the context. ----- >>> import Prelude (Bool (..), Either (..), not)+-- >>> import Prelude (Bool (..), Either (..), id, not) -- >>> caseEither @Bool @Bool @Bool (Left True, (not, id)) -- False -- >>> caseEither @Bool @Bool @Bool (Right True, (not, id)) -- True caseEither-  :: forall {k} (a :: k) b c. (BiCCC k, Ob a, Ob b, Ob c) => ((a || b) && ((a ~~> c) && (b ~~> c))) ~> c+  :: forall {k} (a :: k) b c+   . (HasProducts k, Closed (PROD k), Distributive (PROD k), Ob a, Ob b, Ob c)+  => Interp ((F a :|| F b) :** ((F a :-> F c) :** (F b :-> F c))) ~> c caseEither =-  toCCC @((F a || F b) && ((F a ~~> F c) && (F b ~~> F c))) @(F c)-    (lam (\p -> let (ab :& q) = p in let (ac :& bc) = q in either ac bc ab))+  withObExp @(PROD k) @(PR a) @(PR c)+    ( withObExp @(PROD k) @(PR b) @(PR c)+        ( toCCC @((F a :|| F b) :** ((F a :-> F c) :** (F b :-> F c))) @(F c)+            (\(ab, (ac, bc)) -> caseOf ab (\a -> ac ! a) (\b -> bc ! b))+        )+    )
+ src/Proarrow/Tools/ContractionOrder.hs view
@@ -0,0 +1,106 @@+-- | The order to contract a network of factors in, such as a tensor network or the states of an+-- open hypergraph: which two to contract first, then which two of the factors and results, and so+-- on. Contracting two factors makes a factor on the nodes of both that something else still needs,+-- so its size depends on the order, and a bad order can make the intermediate results far larger+-- than the network itself.+--+-- 'planContraction' makes two plans and takes the one whose contractions are smaller together:+-- numpy's greedy order, and an elimination order of the nodes from the min-fill heuristic for tree+-- decompositions, as in Peterseim and Lopuhaä-Zwakenberg, /Fixed-Parameter Tractable Inference for+-- Discrete Probabilistic Programs, via String Diagram Algebraisation/ (LICS 2026).+module Proarrow.Tools.ContractionOrder (Plan (..), planContraction, minFillOrder) where++import Data.Containers.ListUtils (nubOrd)+import Data.List qualified as List+import Data.Map.Strict qualified as M+import Data.Ord (comparing)+import Data.Set (Set)+import Data.Set qualified as Set+import Prelude++-- | A plan to contract factors: one of them, by its place in the list, or the contraction of the+-- results of two plans.+data Plan = Factor Int | Contract Plan Plan+  deriving (Eq, Show)++-- | A part of a plan: its plan, how many of its factors touch each node, the nodes something+-- outside it needs, and the size of its contractions together.+data Part n = Part {plan :: Plan, counts :: M.Map n Int, open :: Set n, cost :: ~Double}++-- | Plans to contract the given factors, each given by its nodes, until no two of the results share+-- a node that may be contracted: a plan for each result. A result keeps the nodes that the given+-- set needs or that factors outside it touch, and its size is the size of those nodes. Of numpy's+-- greedy order, which contracts the pair that shares such a node and whose result grows least, its+-- size less those of the two parts, and of the min-fill elimination order of those nodes, which+-- contracts the parts on each node in turn, the pair that grows least first, the plan whose+-- contractions are smaller together is taken.+--+-- >>> planContraction (fromIntegral . length) (const True) mempty [Set.fromList "ab", Set.fromList "bc", Set.fromList "cd"]+-- [Contract (Contract (Factor 0) (Factor 1)) (Factor 2)]+planContraction :: (Ord n) => (Set n -> Double) -> (n -> Bool) -> Set n -> [Set n] -> [Plan]+planContraction size contractible needed factors+  -- with at most two factors on contractible nodes there is only one plan+  | [i, j] <- candidates =+      if any contractible (Set.intersection (factors !! i) (factors !! j))+        then Contract (Factor i) (Factor j) : others i j+        else alone+  | [_] <- candidates = alone+  | [] <- candidates = alone+  | all (isFactor . plan) greedy = plan <$> greedy+  | otherwise = plan <$> if total greedy <= total eliminated then greedy else eliminated+  where+    candidates = [i | (i, f) <- zip [0 ..] factors, any contractible f]+    alone = Factor <$> [0 .. length factors - 1]+    others i j = [Factor k | k <- [0 .. length factors - 1], k /= i, k /= j]+    leaves = [part (Factor i) (M.fromSet (const 1) f) 0 | (i, f) <- zip [0 ..] factors]+    greedy = contract leaves+    eliminated = along (minFillOrder (size . Set.fromList) (Set.toList . open <$> leaves) nodes) leaves+    total ps = sum (cost <$> ps)+    nodes = nubOrd [n | f <- factors, n <- Set.toList f, contractible n]+    totals = M.fromListWith (+) [(n, 1) | f <- factors, n <- Set.toList f]+    part p cs c = Part p cs (M.keysSet (M.filterWithKey (\n k -> k < totals M.! n || n `Set.member` needed) cs)) c+    merge a b =+      part+        (Contract (plan a) (plan b))+        (M.unionWith (+) (counts a) (counts b))+        (cost a + cost b + size (Set.union (open a) (open b)))+    isFactor Factor{} = True+    isFactor Contract{} = False+    shares a b = any contractible (Set.intersection (open a) (open b))+    pairsOf ps = [(a, b) | a : rest <- List.tails ps, b <- rest]+    -- of the given pairs, the one whose contraction grows least, with that contraction+    best pairs = case [(size (open ab) - size (open a) - size (open b), (a, b, ab)) | (a, b) <- pairs, let ab = merge a b] of+      [] -> Nothing+      cs -> Just (snd (List.minimumBy (comparing fst) cs))+    replaced a b ab ps = [if plan q == plan a then ab else q | q <- ps, plan q /= plan b]+    contract ps = case best [(a, b) | (a, b) <- pairsOf ps, shares a b] of+      Just (a, b, ab) -> contract (replaced a b ab ps)+      Nothing -> ps+    along [] ps = ps+    along (n : ns) ps = case best (pairsOf [p | p <- ps, n `Set.member` open p]) of+      Just (a, b, ab) -> along (n : ns) (replaced a b ab ps)+      Nothing -> along ns ps++-- | An order to eliminate the given vertices of a graph in, by the min-fill heuristic for tree+-- decompositions. The graph has an edge between any two vertices of a common clique. Eliminating a+-- vertex joins its neighbours, so the next vertex is the one whose neighbours lack the fewest edges+-- among themselves, and of those the one whose neighbours weigh least together. A star is+-- eliminated from its leaves:+--+-- >>> minFillOrder length [[0, 1], [0, 2], [0, 3 :: Int]] [0, 1, 2, 3]+-- [1,2,0,3]+minFillOrder :: (Ord a, Ord w) => ([a] -> w) -> [[a]] -> [a] -> [a]+minFillOrder weight cliques = go graph+  where+    graph = M.fromListWith Set.union [(v, Set.fromList (filter (/= v) c)) | c <- cliques, v <- c]+    neighbours g v = M.findWithDefault Set.empty v g+    go _ [] = []+    go g vs =+      let v = List.minimumBy (comparing (fill g)) vs+          nbs = neighbours g v+          -- only the neighbours of v change: they lose v and become adjacent to each other+          joined = foldr (\u -> M.adjust (Set.delete u . Set.union nbs . Set.delete v) u) (M.delete v g) (Set.toList nbs)+      in v : go joined (List.delete v vs)+    fill g v =+      let nbs = Set.toList (neighbours g v)+      in (length [() | (a : rest) <- List.tails nbs, let na = neighbours g a, b <- rest, not (b `Set.member` na)], weight nbs)
src/Proarrow/Tools/Diagrams/Svg.hs view
@@ -1483,7 +1483,8 @@ -- set), which a page can set to its background. document :: Geo -> String document g =-  "<svg xmlns=\"http://www.w3.org/2000/svg\" class=\"sd\" viewBox=\""+  "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+    ++ "<svg xmlns=\"http://www.w3.org/2000/svg\" class=\"sd\" viewBox=\""     ++ unwords (map num [-margin, -margin, geoWidth g + 2 * margin, geoHeight g + 2 * margin])     ++ "\" width=\""     ++ num (geoWidth g + 2 * margin)
src/Proarrow/Tools/Einsum.hs view
@@ -10,7 +10,7 @@ -- -- 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+-- form, and the result is its 'Proarrow.Category.Instance.OpenHypergraph.simplifyHypergraph': 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@@ -38,7 +38,7 @@   , SomeArrow (..)   , SortList   , Wires-  , simplify+  , simplifyHypergraph   , someArrow   , unsafeOpenHypergraph   , unsafePrim@@ -322,7 +322,7 @@   )   => Einsum '[] out (ts :: [([Char], [k])]) r   where-  collect acc = simplify (network @os (P.reverse acc) (chars @out))+  collect acc = simplifyHypergraph (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
+ src/Proarrow/Tools/Optic.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Compile resource-aware SMC programs of optics to forward/backward computations.+-- A wire @'(a, da)@ carries its forward and backward objects. 'optic' and 'opticLegs'+-- expand each primitive to two boxes joined by its residual; 'runOptics' connects them+-- by graph substitution and reads the computation into the target symmetric monoidal category.+-- No trace or Frobenius structure is required of the target.+--+-- For example, an SMC program on @Wires '[ '(Double, Double)]@ can compose the+-- primitive @opticLegs \@Double (\x -> (x, x*x)) (\(x, dy) -> 2*x*dy)@ with+-- @opticLegs \@Double (\x -> (cos x, sin x)) (uncurry (*))@. Applying 'runOptics'+-- gives @(x, dy) -> (sin (x*x), 2*x*cos (x*x)*dy)@. A primitive with several output+-- wires supports an ordinary SMC tuple pattern. An explicit duplication optic can+-- copy a forward value and add its two cotangents on the backward pass.+--+-- This is the optic translation in §10 of Wilson and Zanasi,+-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>.+-- The source program may compose, tensor and permute its wires. Copying, discarding,+-- merging and feedback are rejected when their translated wiring needs stronger structure.+module Proarrow.Tools.Optic (OPTICS, Forward, Backward, optic, opticLegs, runOptics) where++import Data.Map.Strict qualified as M+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..))+import Proarrow.Category.Instance.FinHask (FinHask (..))+import Proarrow.Category.Instance.OpenHypergraph+  ( Box (..)+  , Boxes (..)+  , OPENHG+  , Port (..)+  , Prim+  , SomeHypergraph (..)+  , SomeSort+  , SortList+  , SortOb+  , Sorts+  , WireSorts+  , Wires+  , box+  , permutations+  , reifySorts+  , simplify+  , someArrow+  , sortList+  , sorts+  , unsafeOpenHypergraph+  , unsafePrim+  , unsafeSubstituteWith+  )+import Proarrow.Category.Instance.Product (Fst, Snd)+import Proarrow.Category.Instance.Sub (Sub (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Strictified+  ( Fold+  , Strictified (..)+  , concatMany+  , splitMany+  , withIsListOf+  , type (++)+  )+import Proarrow.Core (CategoryOf (..), Kind, Promonad (..), obj)+import Proarrow.Functor (FunctorForRep (type (@)))+import Proarrow.Object (ListOf (..), SomeOf (..), withKnownAppend, withKnownListOf, pattern Objs)+import Proarrow.Optic (ExOptic, Optic, withLegs)+import Proarrow.Optic.Action (ActFl (..))++-- | Graphs of typed optic primitives. Build boxes with 'optic' or 'opticLegs'; reattaching+-- their hidden labels to other sorts breaks the type agreement used by 'runOptics'.+type OPTICS :: Kind -> Kind+type OPTICS k = OPENHG (k, k) (OpticPrim k)++newtype OpticPrim k = OpticPrim (SomeHypergraph k (Prim k))++-- | The forward objects of a list of optic wires, in boundary order.+type Forward :: [(k, k)] -> [k]+type family Forward xs where+  Forward '[] = '[]+  Forward ('(a, da) ': xs) = a ': Forward xs++-- | The backward objects of a list of optic wires, in boundary order.+type Backward :: [(k, k)] -> [k]+type family Backward xs where+  Backward '[] = '[]+  Backward ('(a, da) ': xs) = da ': Backward xs++-- | A primitive from an existing tensor-action optic, in any encoding supported by 'withLegs'.+optic+  :: forall {k} c (xs :: [(k, k)]) ys+   . ( SymMonoidal k+     , SortList xs+     , SortList ys+     , (Ob (Fold (Forward ys)), Ob (Fold (Backward ys))) => c (ExOptic (ActFl Tensor) (Fold (Forward ys)) (Fold (Backward ys)))+     )+  => Optic c (Fold (Forward xs)) (Fold (Backward xs)) (Fold (Forward ys)) (Fold (Backward ys))+  -> (Wires xs :: OPTICS k) ~> Wires ys+optic o@Objs =+  withLegs @(ActFl Tensor) o \l r -> withActP @Tensor l r \ @m f g -> opticLegs @m @xs @ys f g++-- | A primitive from its two legs, with residual @m@. The residual is produced once by+-- the forward leg and consumed by the backward leg; it needs no comonoid structure.+-- The forward and backward lists of ports are folded with the target's tensor.+opticLegs+  :: forall {k} (m :: k) (xs :: [(k, k)]) ys+   . (SymMonoidal k, Ob m, SortList xs, SortList ys)+  => (Fold (Forward xs) ~> m ** Fold (Forward ys))+  -> (m ** Fold (Backward ys) ~> Fold (Backward xs))+  -> (Wires xs :: OPTICS k) ~> Wires ys+opticLegs f g = withHalves (sorts @_ @xs) $+  withHalves (sorts @_ @ys) $+    case (concatMany @(Forward xs), splitMany @(Forward ys), concatMany @(Backward ys), splitMany @(Backward xs)) of+      (joinForward@Objs, splitForward@Objs, joinBackward@Objs, splitBackward@Objs) ->+        let inputs = concatMap expand (sortList @_ @xs)+            outputs = concatMap expand (sortList @_ @ys)+            ni = length inputs+            no = length outputs+            residual = ni + no+            forward =+              (obj @'[m] ** splitForward) . Str @'[Fold (Forward xs)] @'[m, Fold (Forward ys)] f . joinForward+            backward =+              splitBackward+                . Str @'[m, Fold (Backward ys)] @'[Fold (Backward xs)] g+                . (obj @'[m] ** joinBackward)+            boxes =+              [ Box (unsafePrim (someArrow forward)) [0, 2 .. ni - 1] (residual : [ni, ni + 2 .. residual - 1])+              , Box (unsafePrim (someArrow backward)) (residual : [ni + 1, ni + 3 .. residual - 1]) [1, 3 .. ni - 1]+              ]+            replacement = reifySorts inputs \ @as -> reifySorts outputs \ @bs ->+              SomeHypergraph+                (unsafeOpenHypergraph @(Prim k) @as @bs (inputs ++ outputs ++ [Some @m]) [0 .. ni - 1] [ni .. residual - 1] boxes)+        in box (OpticPrim replacement)++-- | Expand the primitives, move the external backward wires to the other boundary, and+-- read back using 'permutations'. The inputs are the forward source and backward target;+-- the outputs are the forward target and backward source. Empty boundaries fold to the unit.+runOptics+  :: forall {k} (xs :: [(k, k)]) ys+   . (SymMonoidal k)+  => (Wires xs :: OPTICS k) ~> Wires ys+  -> Either String ((Fold (Forward xs) ** Fold (Backward ys)) ~> (Fold (Forward ys) ** Fold (Backward xs)))+runOptics graph@Objs =+  withHalves (sorts @_ @xs) $+    withHalves (sorts @_ @ys) $+      withKnownAppend @SortOb @(Forward xs) @(Backward ys) $+        withKnownAppend @SortOb @(Forward ys) @(Backward xs) $ do+          SomeHypergraph (DecCospan @c (Sub (FinHask ins)) (Sub (FinHask outs)) (Boxes boxes)) <-+            unsafeSubstituteWith expand (\(OpticPrim g) -> g) graph+          let unPort (Port i) = i+              inputs = map unPort (M.elems ins)+              outputs = map unPort (M.elems outs)+              evenPorts = everyOther+              oddPorts = everyOther . drop 1+              computation =+                unsafeOpenHypergraph @(Prim k)+                  @(Forward xs ++ Backward ys)+                  @(Forward ys ++ Backward xs)+                  (sortList @_ @(WireSorts (DC c)))+                  (evenPorts inputs ++ oddPorts outputs)+                  (evenPorts outputs ++ oddPorts inputs)+                  (map (fmap unPort) boxes)+          result <- simplify permutations computation+          pure $+            unStr+              ((concatMany @(Forward ys) ** concatMany @(Backward xs)) . result . (splitMany @(Forward xs) ** splitMany @(Backward ys)))+  where+    everyOther [] = []+    everyOther (x : rest) = x : everyOther (drop 1 rest)++expand :: (CategoryOf k) => SomeSort (k, k) -> [SomeSort k]+expand (Some @p) = [Some @(Fst @ p), Some @(Snd @ p)]++withHalves+  :: forall {k} xs r+   . (CategoryOf k)+  => Sorts (xs :: [(k, k)])+  -> ( ( SortList (Forward xs)+       , SortList (Backward xs)+       , Ob (Forward xs)+       , Ob (Backward xs)+       )+       => r+     )+  -> r+withHalves xs k = go xs \as ds ->+  withKnownListOf as $+    withKnownListOf ds $+      withIsListOf as $+        withIsListOf ds k+  where+    go :: Sorts (zs :: [(k, k)]) -> (Sorts (Forward zs) -> Sorts (Backward zs) -> r) -> r+    go Nil next = next Nil Nil+    go (Cons @p rest) next = go rest \as ds -> next (Cons @(Fst @ p) as) (Cons @(Snd @ p) ds)
src/Proarrow/Tools/SMC.hs view
@@ -1,5 +1,5 @@--- | 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,+-- | A HOAS front end for building morphisms in any symmetric monoidal category, with+-- "Proarrow.Tools.CCC" as its cartesian specialization. It 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@@ -11,22 +11,26 @@ -- 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)@.+-- Arrow application and tuple construction adapt terms from earlier binding depths automatically.+-- Other operations on raw terms may need 'recast' when a variable is used both outside and inside+-- a binder: @x ** lam (\\z -> recast x ** z)@.+-- A binder's depth still determines its fresh variable ids. If that depth cannot be inferred+-- for a lambda passed to '(-<)', bind the lambda in @do@ first. -- -- 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.+-- constructor, so patterns can determine its shape without inverting the target's @**@ type family. -- -- 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+-- 'toSMC' and used with '(-<)' or 'lift'; a piece without inputs takes 'unit'. '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+-- @rec@ block traces, which needs a traced monoidal category for 'Term', or+-- 'Proarrow.Category.Monoidal.Strength.Costrong' 'Proarrow.Category.Monoidal.Tensor' @p@ for+-- 'TermP' @p@. 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. --@@ -69,19 +73,24 @@      -- ** Symmetric monoidal categories   , Term+  , TermP   , toSMC+  , toSMC1+  , proc   , lift+  , liftF+  , (-<)+  , returnA   , unit   , (**)   , split   , Tuple   , TupleCtx-  , TupleDepth   , recast      -- ** Closed categories   , lam-  , (!)+  , Apply (..)      -- ** CopyDiscard / Comonoids   , dup@@ -130,6 +139,8 @@   , inl   , inr   , caseOf+  , ifThenElse+  , Sum   , absurd      -- * Contexts@@ -164,15 +175,52 @@ -- '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,+-- matches the unit 'I'. A pair matches a tensor @a ':**' b@ and binds its two sides, and a tuple+-- of three to six 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.+-- A pair also matches @'F' (a ** b)@, binding terms of @'F' a@ and @'F' b@. The morphism and+-- uses of the pattern's variables determine the component objects. -- -- 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.+--+-- '(-<)' mirrors arrow application in Haskell's arrow notation. The wiring of+--+-- > proc (x, y) -> do+-- >   z <- f -< x+-- >   returnA -< (z, y)+--+-- can be written as+--+-- > toSMC \(x, y) -> SMC.do+-- >   z <- f -< x+-- >   returnA -< (z, y)+--+-- Here 'toSMC' binds the input wires, and 'returnA' is the identity morphism.+-- '(-<)' is infix 'liftF': @f -< (x, y)@ applies @f@ to @x ** y@ and embeds its result by 'F'.+-- Use 'lift' for composite result syntax.+-- A tensor result can also be taken apart directly with a pattern:+--+-- > toSMC \z -> SMC.do+-- >   (x, y) <- f -< z+-- >   returnA -< (y, x)+--+-- 'proc' compiles the same way to an arrow of a promonad @p@ instead of a morphism, such as an+-- 'Proarrow.Profunctor.Instance.Arrow.Arr' wrapping a "Control.Arrow" arrow. Then '(-<)' takes+-- arrows of @p@, variables are values of the category, and the computations run in the order+-- they are written: statements from top to bottom, the parts of a tuple from left to right.+-- Terms at @p@ are 'TermP' @p@. Most operations work at any @p@, using the category's pure+-- structure through profunctor mapping. 'inl' and 'inr' use the category's pure injections; 'caseOf'+-- additionally needs 'Proarrow.Category.Monoidal.Distributive.DistributiveProfunctor' @p@,+-- supplied by 'Control.Arrow.ArrowChoice' for 'Proarrow.Profunctor.Instance.Arrow.Arr'. The+-- scrutinee may use '(:||)' or be a sum embedded by 'F', including a result of '(-<)'. The+-- operations 'loop' and @rec@ blocks need 'Proarrow.Category.Monoidal.Strength.Costrong'+-- 'Proarrow.Category.Monoidal.Tensor' @p@, supplied by 'Control.Arrow.ArrowLoop' for+-- 'Proarrow.Profunctor.Instance.Arrow.Arr'. 'with', 'lam', 'cont', and the special tuple and+-- bind rules at 'Up' work at @p = ('~>')@, that is 'Term'.  -- $index -- Index notation, as in Einstein summation, for a category whose index types are special@@ -180,11 +228,11 @@ -- 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+-- @'delta' (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+-- > \i -> sumOver \k -> sumOver \j -> delta (f -< i) j *^ delta (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
src/Proarrow/Tools/SMC/Examples.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RebindableSyntax #-} {-# LANGUAGE RecursiveDo #-}  -- | Examples of "Proarrow.Tools.SMC". They are compiled at @k = 'Data.Kind.Type'@, where the result@@ -82,7 +83,7 @@ -- >>> 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+traceT h = toSMC1 \a -> SMC.do   rec (b, u) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)   b @@ -92,12 +93,12 @@ -- >>> 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)+loopT h = toSMC1 \a -> loop @(F u) @(F b) \u -> recast (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+loopCC h = toSMC1 \a -> SMC.do   (u, u') <- produce   (b, v) <- lift @(F a :** F u) @(F b :** F u) h (a ** u)   () <- annihilate u' v@@ -107,7 +108,7 @@ -- 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+snakeT = toSMC1 \x -> SMC.do   (a, a') <- produce   () <- annihilate a' x   a@@ -130,7 +131,9 @@ 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))+  if bc+    then \b -> inl (a ** b)+    else \c -> inr (a ** c)  -- | Swap a coproduct, with nothing to share. --@@ -147,7 +150,7 @@ -- ((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)+bothWaysT = toSMC @(F a :** F b) \(x, y) -> (x ** y) `with` (y ** x)  -- | Double negation introduction: a consumer of a consumer of @a@ hands it the @a@. This is -- 'ret', written out.@@ -164,11 +167,11 @@ 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+  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)+contraT f = toSMC @(Not (F b)) @(Not (F a)) \nb -> cont \x -> cut nb (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'.@@ -188,17 +191,17 @@ -- | 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+matMulT f g = toSMC1 \i -> sumOver @(F c) \k -> sumOver @(F b) \j ->+  delta (f -< i) j *^ delta (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+traceIdxT f = toSMC @I \() -> sumOver @(F a) \i -> delta (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+hadamardT f g = toSMC1 \i -> sumOver @(F b) \j ->+  delta (f -< i) j *^ delta (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.
src/Proarrow/Tools/SMC/Internal/Additive.hs view
@@ -4,13 +4,16 @@ -- public module keeps hidden. module Proarrow.Tools.SMC.Internal.Additive where +import Data.Kind (Constraint) import Proarrow.Category.Monoidal qualified as M-import Proarrow.Category.Monoidal.Distributive (Distributive (..))+import Proarrow.Category.Monoidal.Distributive (Distributive (..), DistributiveProfunctor, branch) import Proarrow.Colimit.BinaryCoproduct (HasBinaryCoproducts (..)) import Proarrow.Colimit.Initial (HasInitialObject (..))-import Proarrow.Core (Promonad (..), obj)+import Proarrow.Core (CAT, Profunctor (..), Promonad (..), obj) import Proarrow.Limit.BinaryProduct (HasBinaryProducts (..)) import Proarrow.Limit.Terminal (HasTerminalObject (..))+import Proarrow.Object (pattern Objs)+import Prelude (($), type (~))  import Proarrow.Tools.SMC.Internal.Context import Proarrow.Tools.SMC.Internal.Pattern@@ -30,76 +33,120 @@ -- | 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))))+  :: forall {k} {p} (a :: SYN k) b d g+   . (HasBinaryProducts k, Profunctor p, KnownObj a, KnownObj b) => TermP p d g (a :&& b) -> TermP p d g a+exl = rmapT (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))))+  :: forall {k} {p} (a :: SYN k) b d g+   . (HasBinaryProducts k, Profunctor p, KnownObj a, KnownObj b) => TermP p d g (a :&& b) -> TermP p d g b+exr = rmapT (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)))+absorb+  :: forall {k} {p} (s :: SYN k) d g. (HasTerminalObject k, Profunctor p, KnownObj s) => TermP p d g s -> TermP p d g Top+absorb = rmapT (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))))+  :: forall {k} (a :: SYN k) b d g p+   . (Profunctor p, HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => TermP p d g a -> TermP p d g (a :|| b)+inl = rmapT @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))))+  :: forall {k} (a :: SYN k) b d g p+   . (Profunctor p, HasBinaryCoproducts k, KnownObj a, KnownObj b)+  => TermP p d g b -> TermP p d g (a :|| b)+inr = rmapT @b @(a :|| b) (withSynOb @a (withSynOb @b (rgt @k @(Interp a) @(Interp b)))) +-- | A sum with components @a@ and @b@: either @a ':||' b@ or a coproduct embedded by 'F'.+type Sum :: forall {k}. SYN k -> SYN k -> SYN k -> Constraint+class (Interp s ~ Interp (a :|| b)) => Sum s a b++-- An unknown input defaults to syntax-level choice, as patterns default to syntax-level tensor.+-- The embedded instance takes over when the input is known to be headed by F.+instance {-# INCOHERENT #-} (s ~ (a :|| b)) => Sum s a b++instance (z ~ (x || y), a ~ F x, b ~ F y) => Sum (F z) a 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.+-- The sum may be written with '(:||)' or embedded by 'F', as in the result of '(-<)'.+-- For 'Proarrow.Profunctor.Instance.Arrow.Arr', this needs 'Control.Arrow.ArrowChoice'+-- and runs only the selected branch. {-# INLINE caseOf #-} caseOf-  :: forall {k} (a :: SYN k) b c d g r1 r2 t1 cont1 t2 cont2+  :: forall {k} (a :: SYN k) b c d g r1 r2 t1 cont1 t2 cont2 s (p :: CAT k)    . ( Distributive k+     , Promonad p+     , DistributiveProfunctor p+     , Sum s a b      , KnownObj a      , KnownObj b-     , Binds d r1 a c t1 cont1-     , Binds d r2 b c t2 cont2+     , Binds p d r1 a c t1 cont1+     , Binds p 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)+  => TermP p d g s   -> (t1 -> cont1)   -> (t2 -> cont2)-  -> Term d (Union (Union r1 r2) g) c+  -> TermP p 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-                )+            ( case lmap (thin @(Union r1 r2) @r1 M.** obj @(Interp a)) (bound @p @d @r1 @a @c f) of+                l@Objs -> case lmap (thin @(Union r1 r2) @r2 M.** obj @(Interp b)) (bound @p @d @r2 @b @c h) of+                  r@Objs ->+                    MkTerm $+                      lmap (merge @(Union r1 r2) @g) $+                        branch+                          (rmap (distL @k @(Interp (Mul (Union r1 r2))) @(Interp a) @(Interp b)) (id @p @(Interp (Mul (Union r1 r2))) M.** x))+                          l+                          r             )         )     ) +-- | 'caseOf' as overloaded @if@ syntax with @RebindableSyntax@. Import 'ifThenElse'+-- unqualified and write @if x then \l -> ... else \r -> ...@. The @then@ branch handles+-- the left alternative and the @else@ branch handles the right; each receives its payload.+{-# INLINE ifThenElse #-}+ifThenElse+  :: forall {k} (a :: SYN k) b c d g r1 r2 t1 cont1 t2 cont2 s (p :: CAT k)+   . ( Distributive k+     , Promonad p+     , DistributiveProfunctor p+     , Sum s a b+     , KnownObj a+     , KnownObj b+     , Binds p d r1 a c t1 cont1+     , Binds p d r2 b c t2 cont2+     , Thin (Union r1 r2) r1+     , Thin (Union r1 r2) r2+     , Merge (Union r1 r2) g+     )+  => TermP p d g s+  -> (t1 -> cont1)+  -> (t2 -> cont2)+  -> TermP p d (Union (Union r1 r2) g) c+ifThenElse = caseOf @a @b @c @d @g @r1 @r2 @t1 @cont1 @t2 @cont2 @s @p+ -- | 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)+  :: forall {k} {p} (s :: SYN k) c d g1 g2+   . (Distributive k, M.MonoidalProfunctor p, KnownObj s, KnownObj c, Merge g1 g2)+  => TermP p d g1 s -> TermP p d g2 Zero -> TermP p d (Union g1 g2) c+absurd e z = rmapT (withSynOb @s (withSynOb @c (initiate @k @(Interp c) . absorbL @k @(Interp s)))) (e ** z)
src/Proarrow/Tools/SMC/Internal/Closed.hs view
@@ -4,10 +4,13 @@ -- the public module keeps hidden. module Proarrow.Tools.SMC.Internal.Closed where +import Data.Kind (Constraint, Type)+import Prelude (type (~))+ 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.Category.Monoidal.Strength (Costrong, trace)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..))  import Proarrow.Tools.SMC.Internal.Context import Proarrow.Tools.SMC.Internal.Pattern@@ -21,30 +24,54 @@ {-# INLINE lam #-} lam   :: forall {k} d r (a :: SYN k) b t cont-   . (Closed k, Binds d r a 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))))+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)+  :: forall {k} {p} (u :: SYN k) b d r t cont+   . (Costrong M.Tensor p, M.SymMonoidal k, KnownObj b, Binds p d r u (b :** u) t cont)   => (t -> cont)-  -> Term d r b+  -> TermP p 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))))+        (withSynOb @b (MkTerm (trace @p @(Interp u) @(Interp (Mul r)) @(Interp b) (bound @p @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)))+-- Explicit exponentials determine their result syntax. Embedded function objects, such as+-- results of '(-<)', take their result syntax from the surrounding term.+type Apply :: forall {k}. CAT k -> Type -> Type -> Type -> Constraint+class Apply (p :: CAT k) f x r | f -> p where+  (!)+    :: (Closed k, M.MonoidalProfunctor p, KnownObj (TyOf @k x), KnownObj (TyOf @k r), Merge (CtxOf @k f) (CtxOf @k x))+    => f -> x -> r++instance (x ~ TermP p d g2 a, r ~ TermP p d (Union g1 g2) b) => Apply p (TermP p d g1 (a :-> b :: SYN k)) x r where+  {-# INLINE (!) #-}+  (!) = applyTerm @a @b++instance+  (f ~ (Interp a ~~> Interp b), x ~ TermP p d g2 a, r ~ TermP p d (Union g1 g2) b)+  => Apply p (TermP p d g1 (F f :: SYN k)) x r+  where+  {-# INLINE (!) #-}+  (!) = applyTerm @a @b++{-# INLINE applyTerm #-}+applyTerm+  :: forall {k} (a :: SYN k) b p d g1 g2 f+   . (Closed k, M.MonoidalProfunctor p, KnownObj a, KnownObj b, Merge g1 g2, Interp f ~ (Interp a ~~> Interp b))+  => TermP p d g1 f+  -> TermP p d g2 a+  -> TermP p d (Union g1 g2) b+applyTerm (MkTerm f) (MkTerm x) =+  withSynOb @a+    ( withSynOb @b+        (MkTerm (dimap (merge @g1 @g2) (apply @k @(Interp a) @(Interp b)) (f M.** x)))+    )
src/Proarrow/Tools/SMC/Internal/Dialogue.hs view
@@ -6,12 +6,12 @@  import Data.Kind (Type) import GHC.TypeNats (Nat)-import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor) 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.Core (CategoryOf (..), Profunctor, Promonad (..), arr, type (+->))  import Proarrow.Tools.SMC.Internal.Context import Proarrow.Tools.SMC.Internal.Pattern@@ -24,24 +24,28 @@ -- | 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)))+produce :: forall {k} {p} (a :: SYN k) d. (CompactClosed k, Promonad p, KnownObj a) => TermP p d '[] (a :** Not a)+produce = withSynOb @a (MkTerm (arr (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)+  :: forall {k} {p} (a :: SYN k) d g1 g2+   . (IsoMix k, MonoidalProfunctor p, KnownObj a, Merge g1 g2)+  => ConsumerP p d g1 a -> TermP p d g2 a -> TermP p d (Union g1 g2) I+annihilate x y = rmapT (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 ConsumerP :: forall {k}. k +-> k -> Nat -> Ctx k -> SYN k -> Type+type ConsumerP p d g a = TermP p d g (Not a)+ 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 CommandP :: forall {k}. k +-> k -> Nat -> Ctx k -> Type+type CommandP p d g = TermP p d g (Not I)+ 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'.@@ -51,17 +55,17 @@ -- | 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)+  :: forall {k} {p} (a :: SYN k) d g1 g2+   . (Dialogue k, MonoidalProfunctor p, KnownObj a, Merge g1 g2)+  => ConsumerP p d g1 a -> TermP p d g2 a -> CommandP p d (Union g1 g2)+cut x y = rmapT (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)+  :: forall {k} {p} (a :: SYN k) d g1 g2+   . (Dialogue k, MonoidalProfunctor p, KnownObj a, Merge g2 g1)+  => TermP p d g1 a -> ConsumerP p d g2 a -> CommandP p 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@@ -77,7 +81,7 @@ {-# INLINE cont #-} cont   :: forall {k} d r (a :: SYN k) t cont-   . (Dialogue k, Binds d r a (Not I) t cont)+   . (Dialogue k, Binds (~>) d r a (Not I) t cont)   => (t -> cont)   -> Term d r (Not a) cont k =@@ -85,7 +89,7 @@     ( withSynOb @a         ( MkTerm             ( dual (rightUnitorInv @k @(Interp a))-                . linDist @k @(Interp (Mul r)) @(Interp a) @Unit (bound @d @r @a @(Not I) k)+                . linDist @k @(Interp (Mul r)) @(Interp a) @Unit (bound @(~>) @d @r @a @(Not I) k)             )         )     )@@ -93,17 +97,18 @@ -- | 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 :: forall {k} {p} (n :: SYN k) d g. TermP p d g n -> TermP p 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 :: forall {k} {p} (n :: SYN k) d g. TermP p d g (Dn n) -> TermP p 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)))+classical+  :: forall {k} {p} (a :: SYN k) d g. (StarAutonomous k, Profunctor p, KnownObj a) => TermP p d g (Up a) -> TermP p d g a+classical = withSynOb @a (rmapT (doubleNeg @k @(Interp a)))
src/Proarrow/Tools/SMC/Internal/Do.hs view
@@ -6,11 +6,11 @@  import Data.Kind (Constraint, Type) import GHC.TypeNats (Nat, type (+))-import Proarrow.Category.Monoidal (Monoidal, Tensor)+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor, SymMonoidal, 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 Proarrow.Category.Monoidal.Dialogue (Dialogue (..))+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Core (CAT, Hom, Profunctor (..), Promonad (..)) import Prelude (type (~)) import Prelude qualified as P @@ -22,22 +22,22 @@ -- 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+type Bind :: forall {k}. CAT k -> Type -> Type -> Type -> Type -> Constraint+class Bind p m t cont r | m -> p 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+instance {-# INCOHERENT #-} (BindTerm p t (TermP p d g a) cont r) => Bind p (TermP p d g (a :: SYN k)) t cont r where   {-# INLINE (>>=) #-}-  (>>=) = bindTerm @k @t+  (>>=) = bindTerm @p @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+type BindTerm :: forall {k}. CAT k -> Type -> Type -> Type -> Type -> Constraint+class BindTerm p 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@@ -45,54 +45,88 @@  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'+  (Promonad p, MonoidalProfunctor p, Binds p d r a b t cont, Merge r g, r' ~ TermP p d (Union r g) b)+  => BindTerm p t (TermP p 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))+  bindTerm (MkTerm m) k =+    withCtxOb @r (MkTerm (bound @p @d @r @a @b k . lmap (merge @r @g) (id @p @(Interp (Mul r)) M.** m))) -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+instance+  {-# INCOHERENT #-}+  (BindPat p (TermP p d g a) (x, y) cont r)+  => BindTerm p (x, y) (TermP p 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+  (BindPat p (TermP p d g a) (x, y, z) cont r)+  => BindTerm p (x, y, z) (TermP p 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+  (BindPat p (TermP p d g a) (w, x, y, z) cont r)+  => BindTerm p (w, x, y, z) (TermP p 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+instance+  {-# INCOHERENT #-}+  (BindPat p (TermP p d g a) (v, w, x, y, z) cont r)+  => BindTerm p (v, w, x, y, z) (TermP p d g (a :: SYN k)) cont r+  where   {-# INLINE bindTerm #-}   bindTerm = bindPat +instance+  {-# INCOHERENT #-}+  (BindPat p (TermP p d g a) (u, v, w, x, y, z) cont r)+  => BindTerm p (u, v, w, x, y, z) (TermP p d g (a :: SYN k)) cont r+  where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++instance+  {-# INCOHERENT #-}+  (BindPat p (TermP p d g a) () cont r)+  => BindTerm p () (TermP p d g (a :: SYN k)) cont r+  where+  {-# INLINE bindTerm #-}+  bindTerm = bindPat++-- An explicit consumer determines what it consumes. An embedded dual object instead+-- uses the negative result expected by the surrounding computation.+type Negative :: forall {k}. SYN k -> SYN k -> Constraint+class (Interp c ~ Dual (Interp y)) => Negative c y++instance (y ~ y') => Negative (Not y') y+instance (f ~ Dual (Interp y)) => Negative (F f) y+ -- | A computation on the right hand side runs first, and the rest of the block is negative. instance-  ( Dialogue k+  ( p ~ Hom k+  , 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)+  , Negative (TyOf @k cont) y+  , Binds p d r a (TyOf @k cont) t cont+  , r' ~ TermP p d (Union g r) (Not y)   )-  => Bind k (Term d g (Not (Not a))) t cont r'+  => Bind p (TermP p d g (Not (Not a) :: SYN k)) t cont r'   where   {-# INLINE (>>=) #-}-  m >>= k = runUp @d @g @r @a @y m (bound @d @r @a @(Not y) k)+  m >>= k = runUp @d @g @r @a @y m (bound @p @d @r @a @(TyOf @k cont) 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+  (Bind p (TermP p d g a) t cont r', r ~ Ret tt r')+  => Bind p (TermP p d g (a :: SYN k)) t (Ret tt cont) r   where   {-# INLINE (>>=) #-}   x >>= k = Ret (x >>= \p -> unRet (k p))@@ -107,34 +141,40 @@  -- | The variables of a @rec@ block, as GHC tuples them up. type RecVars :: Type -> Type -> Constraint-class RecVars k t | t -> k where+-- The empty tuple contains no term from which to recover the category.+class RecVars k t where   type Vars k t :: Ctx k   recVars :: t -instance (Monoidal k, KnownObj (a :: SYN k)) => RecVars k (Term d '[ '(n, a)] a) where+instance RecVars k () where+  type Vars k () = '[]   {-# INLINE recVars #-}-  type Vars k (Term d '[ '(n, a)] a) = '[ '(n, a)]+  recVars = ()++instance (Promonad p, KnownObj (a :: SYN k)) => RecVars k (TermP (p :: CAT k) d '[ '(n, a)] a) where+  {-# INLINE recVars #-}+  type Vars k (TermP p 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)+  recVars = (recVars @k, recVars @k)  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)+  recVars = (recVars @k, recVars @k, recVars @k)  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)+  recVars = (recVars @k, recVars @k, recVars @k, recVars @k)  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)+  recVars = (recVars @k, recVars @k, recVars @k, recVars @k, recVars @k)  instance   (RecVars k x, RecVars k y, RecVars k z, RecVars k w, RecVars k v, RecVars k u)@@ -142,7 +182,7 @@   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)+  recVars = (recVars @k, recVars @k, recVars @k, recVars @k, recVars @k, recVars @k)  -- | 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@@ -150,8 +190,10 @@ type AnyDepth :: Type -> Type -> Constraint class AnyDepth t t' -instance (t' ~ Term d' g a) => AnyDepth (Term d g a) t'+instance (t' ~ ()) => AnyDepth () t' +instance (t' ~ TermP p d' g a) => AnyDepth (TermP p 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'@@ -176,33 +218,45 @@ -- | 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)))+  :: forall k t d (p :: CAT k)+   . (Monoidal k, Promonad p, RecVars k t, KnownCtx (Vars k t))+  => t -> Ret t (TermP p d (Vars k t) (Mul (Vars k t)))+return _ = withCtxOb @(Vars k t) (Ret (MkTerm (id @p @(Interp (Mul (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+type Rec :: forall {k}. CAT k -> Nat -> Type -> Ctx k -> Type+data Rec p d t g where+  Rec :: forall {k} (p :: CAT k) d t (g :: Ctx k). p (Interp (Mul g)) (Interp (Mul (Vars k t))) -> Rec p 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+mfix+  :: forall {k} t d (g :: Ctx k) (p :: CAT k). (RecVars k t) => (t -> Ret t (TermP p d g (Mul (Vars k t)))) -> Rec p d t g+mfix f = case unRet (f (recVars @k @t)) of MkTerm body -> Rec body +-- The continuation stays at the same depth if GHC retains no variables of the block.+type RecDepth :: forall {k}. Nat -> Ctx k -> Nat+type family RecDepth d g where+  RecDepth d '[] = d+  RecDepth d ('(n, a) ': g) = n + 1+ -- | 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+  ( Promonad p+  , MonoidalProfunctor p+  , Costrong Tensor p+  , SymMonoidal 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)+  , cont ~ TermP p (RecDepth d (Vars k t)) (CtxOf @k cont) (TyOf @k cont)+  , r ~ TermP p 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)))@@ -211,7 +265,7 @@   , 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+  => Bind p (Rec p d t (g :: Ctx k)) t' cont r   where   {-# INLINE (>>=) #-}   Rec body >>= k = case k (recVars @k @t') of@@ -222,21 +276,24 @@                 ( 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))+                            . dimap+                              (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)))+                              ( id @p @(Interp (Mul (Minus (CtxOf @k cont) (Vars k t))))                                   M.** coact                                     @Tensor-                                    @(~>)+                                    @p                                     @(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))+                                    ( dimap+                                        (unmerge @(Inter g (Vars k t)) @(Minus g (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                                     )                               )-                            . merge @(Minus (CtxOf @k cont) (Vars k t)) @(Minus g (Vars k t))                         )                     )                 )
src/Proarrow/Tools/SMC/Internal/Frobenius.hs view
@@ -6,10 +6,11 @@  import GHC.TypeNats (type (+)) -import Proarrow.Category.Monoidal (Monoidal (..), rightUnitorInvWith)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor, rightUnitorInvWith) import Proarrow.Category.Monoidal.Hypergraph (Frobenius, cap)-import Proarrow.Core (Promonad (..))+import Proarrow.Core (Profunctor (..), Promonad (..)) import Proarrow.Monoid (Monoid (..))+import Prelude (type (~))  import Proarrow.Tools.SMC.Internal.Context import Proarrow.Tools.SMC.Internal.Pattern@@ -24,15 +25,15 @@ -- 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)+  :: forall {k} {p} (a :: SYN k) d r b t cont+   . (Profunctor p, Frobenius (Interp a), Binds p d r a b t cont)   => (t -> cont)-  -> Term d r b+  -> TermP p d r b sumOver k =   withCtxOb @r     ( withSynOb @a         ( MkTerm-            (bound @d @r @a @b k . rightUnitorInvWith @(Interp (Mul r)) (mempty @(Interp a)))+            (lmap (rightUnitorInvWith @(Interp (Mul r)) (mempty @(Interp a))) (bound @p @d @r @a @b k))         )     ) @@ -40,37 +41,38 @@ -- @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+  :: forall {k} {p} (a :: SYN k) d g' g b+   . (Profunctor p, Frobenius (Interp a), KnownObj a, BindVar d a g' g)+  => TermP p (d + 1) g' b+  -> TermP p d g b sumVar (MkTerm body) =   withCtxOb @g     ( withSynOb @a-        (MkTerm (body . bindVar @d @a @g' @g . rightUnitorInvWith @(Interp (Mul g)) (mempty @(Interp a))))+        (MkTerm (lmap (bindVar @d @a @g' @g . rightUnitorInvWith @(Interp (Mul g)) (mempty @(Interp a))) body))     )  -- | 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)+  :: forall {k} {p} (a :: SYN k) d g1 g2+   . (MonoidalProfunctor p, Frobenius (Interp a), KnownObj a, Merge g1 g2)+  => TermP p d g1 a -> TermP p d g2 a -> TermP p d (Union g1 g2) I+delta x y = rmapT (cap @(Interp a)) (x ** y) --- | A term multiplied by a scalar on its left. At 'I' it is the product of two scalars.+-- | A term multiplied by a scalar on its left. The scalar's type interprets to 'Unit',+-- including both 'I' and @'F' Unit@. 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)+  :: forall {k} {p} d g1 g2 (a :: SYN k) s+   . (MonoidalProfunctor p, KnownObj a, Merge g1 g2, Interp s ~ Unit)+  => TermP p d g1 s -> TermP p d g2 a -> TermP p d (Union g1 g2) a+s *^ x = withSynOb @a (rmapT (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)+  :: forall {k} {p} d g1 g2 (a :: SYN k) s+   . (MonoidalProfunctor p, KnownObj a, Merge g1 g2, Interp s ~ Unit)+  => TermP p d g1 a -> TermP p d g2 s -> TermP p d (Union g1 g2) a+x ^* s = withSynOb @a (rmapT (rightUnitor @k @(Interp a)) (x ** s))
src/Proarrow/Tools/SMC/Internal/Pattern.hs view
@@ -6,10 +6,10 @@  import Data.Kind (Constraint, Type) import GHC.TypeNats (Nat, type (+))-import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor) import Proarrow.Category.Monoidal qualified as M import Proarrow.Category.Monoidal.Dialogue (Dialogue (..), bindDual)-import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Core (CAT, CategoryOf (..), Hom, Profunctor (..), Promonad (..), obj) import Prelude (type (~))  import Proarrow.Tools.SMC.Internal.Context@@ -21,11 +21,61 @@ {-# INLINE toSMC #-} toSMC   :: forall {k} (a :: SYN k) b t cont-   . (Monoidal k, Binds 0 '[] a 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))+toSMC = proc @a @b +-- | 'toSMC' with both boundary objects embedded by 'F'. The surrounding morphism type+-- determines the input and output objects, so their type applications can be omitted.+-- Use 'toSMC' when a boundary needs other syntax, such as a function or computation type.+{-# INLINE toSMC1 #-}+toSMC1+  :: forall {k} (a :: k) b t cont+   . (Monoidal k, Binds (~>) 0 '[] (F a) (F b) t cont)+  => (t -> cont) -> a ~> b+toSMC1 = toSMC @(F a) @(F b)++-- | Compile a function on terms to an arrow of the promonad @p@, as 'toSMC' does for the morphisms+-- of the category, which are the case @p = ('~>')@. The terms' computations are arrows of @p@,+-- lifted with '(-<)' or 'lift', and run in the order they are written; variables are values,+-- which the category's structure copies and discards. This mirrors @proc@ in Haskell's arrow+-- notation, whose @Arrows@ extension must be disabled.+{-# INLINE proc #-}+proc+  :: forall {k} (a :: SYN k) b t cont (p :: CAT k)+   . (MonoidalProfunctor p, Binds p 0 '[] a b t cont)+  => (t -> cont)+  -> p (Interp a) (Interp b)+proc k = withSynOb @a (lmap (leftUnitorInv @k @(Interp a)) (bound @p @0 @'[] @a @b k))++-- | Lift an arrow onto a term or tuple of terms, with its result embedded by 'F'.+-- The result object is inferred from the arrow. Use 'lift' for composite result syntax.+{-# INLINE liftF #-}+liftF+  :: forall {k} (a :: SYN k) b t (p :: CAT k) d+   . (Promonad p, Tuple p t a)+  => p (Interp a) b -> t -> TermP p d (TupleCtx k t) (F b)+liftF f t = lift @a @(F b) f (tuple @p t)++infixr 0 -<++-- | Arrow application, mirroring @f -< x@ in Haskell's arrow notation.+-- This is infix 'liftF': the input may be a term or tuple, and the result is embedded by 'F'.+-- The @Arrows@ extension must be disabled, since it reserves this symbol.+{-# INLINE (-<) #-}+(-<)+  :: forall {k} (a :: SYN k) b t (p :: CAT k) d+   . (Promonad p, Tuple p t a)+  => p (Interp a) b -> t -> TermP p d (TupleCtx k t) (F b)+(-<) = liftF @a @b++-- | The identity morphism, named as in Haskell's arrow notation.+-- An alias for 'Proarrow.Core.id'; @returnA -< x@ embeds the input by 'F'.+{-# INLINE returnA #-}+returnA :: (Promonad p, Ob a) => p a a+returnA = id+ -- | 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@.@@ -60,127 +110,134 @@ -- 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)+  :: forall {k} {p} (a :: SYN k) t d+   . (Dialogue k, Profunctor p, KnownObj a, Tuple p t a)+  => t -> TermP p d (TupleCtx k t) (Up a)+ret t = withSynOb @a (rmapT (doubleNegInv @k @(Interp a)) (tuple @p @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+-- computation of the pair at @a@. A tuple of three to six stands for pairs nested to the left, as in+-- patterns. The parts may come from different binding depths; the result adopts the depth+-- where it is used, and their contexts are merged.+type Tuple :: forall {k}. CAT k -> Type -> SYN k -> Constraint+class Tuple (p :: CAT k) t a where+  tuple :: t -> TermP p d (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 (w, x, y, z) = TupleCtx k ((w, x, y), z)+  TupleCtx k (v, w, x, y, z) = TupleCtx k ((v, w, x, y), z)+  TupleCtx k (u, v, w, x, y, z) = TupleCtx k ((u, v, 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+-- | A term keeps its context and type, adapting to the depth where it is used.+-- Variable ids in the context are unchanged.+instance {-# INCOHERENT #-} (t ~ TermP p d g a) => Tuple p t a where   {-# INLINE tuple #-}-  tuple t = t+  tuple t = recast t  -- | A pair at a tensor is the tensor of its parts. instance   {-# INCOHERENT #-}-  ( Monoidal k+  ( MonoidalProfunctor p   , a ~ (a1 :** a2)-  , Tuple k x a1-  , Tuple k y a2-  , TupleDepth y ~ TupleDepth x+  , Tuple p x a1+  , Tuple p y a2   , Merge (TupleCtx k x) (TupleCtx k y)   )-  => Tuple k (x, y) (a :: SYN k)+  => Tuple p (x, y) (a :: SYN k)   where   {-# INLINE tuple #-}-  tuple (x, y) = tuple @k @x @a1 x ** tuple @k @y @a2 y+  tuple (x, y) = tuple @p @x @a1 x ** tuple @p @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+instance (Dialogue k, Profunctor p, KnownObj a, Tuple p (x, y) a) => Tuple p (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+instance (Tuple p ((x, y), z) a) => Tuple p (x, y, z) a where   {-# INLINE tuple #-}-  tuple (x, y, z) = tuple @k @((x, y), z) @a ((x, y), z)+  tuple (x, y, z) = tuple @p @((x, y), z) @a ((x, y), z) -instance (Tuple k (((w, x), y), z) a) => Tuple k (w, x, y, z) a where+instance (Tuple p ((w, x, y), z) a) => Tuple p (w, x, y, z) a where   {-# INLINE tuple #-}-  tuple (w, x, y, z) = tuple @k @(((w, x), y), z) @a (((w, x), y), z)+  tuple (w, x, y, z) = tuple @p @((w, x, y), z) @a ((w, x, y), z) +instance (Tuple p ((v, w, x, y), z) a) => Tuple p (v, w, x, y, z) a where+  {-# INLINE tuple #-}+  tuple (v, w, x, y, z) = tuple @p @((v, w, x, y), z) @a ((v, w, x, y), z)++instance (Tuple p ((u, v, w, x, y), z) a) => Tuple p (u, v, w, x, y, z) a where+  {-# INLINE tuple #-}+  tuple (u, v, w, x, y, z) = tuple @p @((u, v, w, x, y), z) @a ((u, v, 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+type Binds :: forall {k}. CAT k -> Nat -> Ctx k -> SYN k -> SYN k -> Type -> Type -> Constraint+class (KnownObj a, KnownCtx g) => Binds p 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+  bound :: (t -> cont) -> p (Interp (Mul g) ** Interp a) (Interp b)  -- The context of the body is @g'@, which only the instance needs to name. instance-  ( KnownObj a+  ( Promonad p+  , KnownObj a   , KnownCtx g-  , BindPat k (Term (n + 1) '[ '(n, a)] a) t cont (Term (n + 1) g' b)+  , BindPat p (TermP p (n + 1) '[ '(n, a)] a) t cont (TermP p (n + 1) g' b)   , BindVar n a g' g   )-  => Binds n g (a :: SYN k) b t cont+  => Binds p 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+  bound k =+    case bindPat @p @(TermP p (n + 1) '[ '(n, a)] a) @t @cont @(TermP p (n + 1) g' b) (var @n @a @(n + 1) @p) k of+      MkTerm body -> lmap (bindVar @n @a @g' @g) body  -- | 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+type BindPat :: forall {k}. CAT k -> Type -> Type -> Type -> Type -> Constraint+class BindPat p m t cont r | m -> p 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+  ( cont ~ TermP p (d + PSize t) (CtxOf @k cont) (TyOf @k cont)+  , r ~ TermP p d gr (TyOf @k cont)+  , Pat p t d g a (CtxOf @k cont) (TyOf @k cont) gr   )-  => BindPat k (Term d g (a :: SYN k)) t cont r+  => BindPat p (TermP p 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+  bindPat = pat @p @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+-- | A pattern: a variable, @()@, or a pair of patterns. A tuple of three to six 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+type Pat :: forall {k}. CAT k -> Type -> Nat -> Ctx k -> SYN k -> Ctx k -> SYN k -> Ctx k -> Constraint+class Pat p t d g a g' c gr where+  pat :: TermP p d g a -> (t -> TermP p (d + PSize t) g' c) -> TermP p 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 (w, x, y, z) = PSize ((w, x, y), z)+  PSize (v, w, x, y, z) = PSize ((v, w, x, y), z)+  PSize (u, v, w, x, y, z) = PSize ((u, v, w, x, y), z)   PSize t = 0  -- The generic instances are incoherent: a variable pattern's type is often still unknown when the@@ -189,8 +246,8 @@  -- | 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+  (p ~ Hom k, Dialogue k, KnownObj y, c ~ Not y, Merge g g', gr ~ Union g g')+  => Pat p () d g (Not (Not I) :: SYN k) g' c gr   where   {-# INLINE pat #-}   pat u k = case k () of@@ -199,67 +256,95 @@ -- | 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+  ( p ~ Hom k+  , Dialogue k   , KnownObj a   , KnownObj y   , c ~ Not y-  , Pat k (x, y') d '[ '(d, a)] a g' c gp+  , Pat p (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+  => Pat p (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+  pat m k = case pat @p @(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+  (MonoidalProfunctor p, a ~ I, KnownObj c, Merge g g', gr ~ Union g g')+  => Pat p () 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'))+    MkTerm t -> withSynOb @c (MkTerm (dimap (merge @g @g') (leftUnitor @k @(Interp c)) (u M.** t)))  -- | 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+instance {-# INCOHERENT #-} (t ~ TermP p (DepthOf t) g a, gr ~ g') => Pat p t d g a g' c gr where   {-# INLINE pat #-}   pat x k = k (recast x) +-- | A pair pattern at an embedded tensor exposes its two embedded components.+-- The tensor pattern supplies the binding and context operations. instance+  ( a ~ (a1 ** a2)+  , Pat p (x, y) d g (F a1 :** F a2) g' c gr+  )+  => Pat p (x, y) d g (F (a :: k)) g' c gr+  where+  {-# INLINE pat #-}+  pat (MkTerm f) k = pat @p @(x, y) @d @g @(F a1 :** F a2) (MkTerm f) k++instance   {-# INCOHERENT #-}-  ( Monoidal k+  ( Promonad p+  , MonoidalProfunctor p   , 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+  , Pat p y (d + 2 + PSize x) '[ '(d + 1, a2)] a2 g' c gy+  , Pat p 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+  => Pat p (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+          pat @p @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)))+            (\px -> pat @p @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+instance {-# INCOHERENT #-} (Pat p ((x, y), z) d g a g' c gr) => Pat p (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))+  pat s k = pat @p @((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+instance {-# INCOHERENT #-} (Pat p ((w, x, y), z) d g a g' c gr) => Pat p (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))+  pat s k = pat @p @((w, x, y), z) @d @g @a @g' @c @gr s (\((pw, px, py), pz) -> k (pw, px, py, pz))++instance {-# INCOHERENT #-} (Pat p ((v, w, x, y), z) d g a g' c gr) => Pat p (v, w, x, y, z) d g a g' c gr where+  {-# INLINE pat #-}+  pat s k = pat @p @((v, w, x, y), z) @d @g @a @g' @c @gr s (\((pv, pw, px, py), pz) -> k (pv, pw, px, py, pz))++instance+  {-# INCOHERENT #-}+  (Pat p ((u, v, w, x, y), z) d g a g' c gr)+  => Pat p (u, v, w, x, y, z) d g a g' c gr+  where+  {-# INLINE pat #-}+  pat s k =+    pat @p @((u, v, w, x, y), z) @d @g @a @g' @c @gr+      s+      (\((pu, pv, pw, px, py), pz) -> k (pu, pv, pw, px, py, pz))
src/Proarrow/Tools/SMC/Internal/Term.hs view
@@ -6,9 +6,9 @@  import Data.Kind (Type) import GHC.TypeNats (Nat, type (+))-import Proarrow.Category.Monoidal (Monoidal (..), associatorInv')+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (one), associatorInv') import Proarrow.Category.Monoidal qualified as M-import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Core (CAT, CategoryOf (..), Profunctor (..), Promonad (..), obj) import Proarrow.Monoid (Comonoid (..)) import Prelude (type (~)) @@ -17,94 +17,113 @@  infixl 7 ** --- | A term at binding depth @d@ with context @g@ and type @a@: a morphism from the tensor of--- the context to @a@.+-- | A term at binding depth @d@ with context @g@ and type @a@, whose computations are arrows of+-- the promonad @p@: an arrow of @p@ from the tensor of the context to @a@. Variables and the+-- structure of contexts are morphisms of the category @k@, which @p@ takes in with 'lmap' and+-- 'rmap'. At @p = ('~>')@ this is 'Term'.+type TermP :: forall {k}. CAT k -> Nat -> Ctx k -> SYN k -> Type+data TermP p d g a where+  MkTerm :: p (Interp (Mul g)) (Interp a) -> TermP p d g a++-- | A term whose computations are the morphisms of the category itself. 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+type Term d g a = TermP (~>) 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)))+var :: forall {k} n (a :: SYN k) d (p :: CAT k). (Promonad p, KnownObj a) => TermP p d '[ '(n, a)] a+var = withSynOb @a (MkTerm (id @p @(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+dup :: forall {k} (s :: SYN k) d g p. (Profunctor p, Comonoid (Interp s)) => TermP p d g s -> TermP p d g (s :** s)+dup = rmapT @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+drop :: forall {k} (s :: SYN k) d g p. (Profunctor p, Comonoid (Interp s)) => TermP p d g s -> TermP p d g I+drop = rmapT @s @I counit --- | Lift a morphism of the target category to a function on terms.+-- | Lift an arrow of the promonad to a function on terms: it runs after the term. {-# 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+  :: forall {k} (a :: SYN k) b d g (p :: CAT k)+   . (Promonad p) => p (Interp a) (Interp b) -> TermP p d g a -> TermP p d g b lift f (MkTerm t) = MkTerm (f . t) --- | Two terms side by side. A variable both use is copied.+-- | Lift a morphism of the category to a function on terms, with 'rmap'. For @p = ('~>')@ this is+-- 'lift'; for other promonads it is how the structure of @k@ acts on terms.+{-# INLINE rmapT #-}+rmapT+  :: forall {k} (a :: SYN k) b d g (p :: CAT k)+   . (Profunctor p) => (Interp a ~> Interp b) -> TermP p d g a -> TermP p d g b+rmapT f (MkTerm t) = MkTerm (rmap f t)++-- | Two terms side by side. A variable both use is copied. With effects, the left term's run+-- first. {-# 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)+  :: forall {k} d g1 g2 (a :: SYN k) b (p :: CAT k)+   . (MonoidalProfunctor p, Merge g1 g2)+  => TermP p d g1 a -> TermP p d g2 b -> TermP p d (Union g1 g2) (a :** b)+MkTerm f ** MkTerm g = MkTerm (lmap (merge @g1 @g2) (f M.** g))  -- | 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 =+  :: forall {k} n (a :: SYN k) b g' r1 r g (p :: CAT k)+   . (Promonad p, MonoidalProfunctor p, KnownObj a, KnownObj b, BindVar (n + 1) b g' r1, BindVar n a r1 r, Merge r g)+  => p (Interp (Mul g)) (Interp a ** Interp b)+  -> p (Interp (Mul (Union r g))) (Interp (Mul g'))+push2 t =   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+        ( dimap+            (merge @r @g)+            ( bindVar @(n + 1) @b @g' @r1+                . (bindVar @n @a @r1 @r M.** obj @(Interp b))+                . associatorInv' (ctxOb @r) (synOb @a) (synOb @b)+            )+            (id @p @(Interp (Mul r)) M.** t)         )     )  -- | 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)+  :: forall {k} d g g' r1 r (a :: SYN k) b c da db (p :: CAT k)+   . (Promonad p, MonoidalProfunctor p, KnownObj a, KnownObj b, BindVar (d + 1) b g' r1, BindVar d a r1 r, Merge r g)+  => TermP p d g (a :** b)+  -> (TermP p da '[ '(d, a)] a -> TermP p db '[ '(d + 1, b)] b -> TermP p (d + 2) g' c)+  -> TermP p d (Union r g) c+split (MkTerm t) k = case k (var @d @a @_ @p) (var @(d + 1) @b @_ @p) of+  MkTerm body -> MkTerm (body . push2 @d @a @b @g' @r1 @r @g @p t)  -- | The unit, which uses no variables. {-# INLINE unit #-}-unit :: forall {k} d. (Monoidal k) => Term d ('[] :: Ctx k) I-unit = MkTerm id+unit :: forall {k} d (p :: CAT k). (MonoidalProfunctor p) => TermP p d ('[] :: Ctx k) I+unit = MkTerm one  -- | 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 :: forall {k} (a :: SYN k) b d d' g p. (Interp a ~ Interp b) => TermP p d g a -> TermP p d' g b recast (MkTerm f) = MkTerm f  type DepthOf :: Type -> Nat type family DepthOf t where-  DepthOf (Term d g a) = d+  DepthOf (TermP p d g a) = d  type CtxOf :: forall k. Type -> Ctx k type family CtxOf t where-  CtxOf (Term d g a) = g+  CtxOf (TermP p d g a) = g  type TyOf :: forall k. Type -> SYN k type family TyOf t where-  TyOf (Term d g a) = a+  TyOf (TermP p d g a) = a
+ test/Examples/CCC.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QualifiedDo #-}++-- | Cartesian SMC terms: products alone, product exponentials independently of the target's+-- tensor, and case analysis with captured variables.+module Examples.CCC (test) where++import Data.Functor.Identity (Identity (..))+import Data.Functor.Product (Product (..))+import Data.Kind (Type)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Instance.Nat (Nat (..), (:~>:) (..))+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Proarrow.Limit.BinaryProduct (HasProducts, PROD, type (&&))+import Proarrow.Testing (expect)+import Proarrow.Testing.Laws (testClosed)+import Proarrow.Tools.CCC (SYN (..), liftF, returnA, toCCC, toCCC1, (!), (**), (-<), type F)+import Proarrow.Tools.CCC qualified as CCC+import Props.Hask ()++-- These signatures check that compiling, lifting, copying and discarding do not require+-- exponentials or coproducts.+duplicate :: forall {k} (a :: k). (HasProducts k, Ob a) => a ~> (a && a)+duplicate = toCCC @(F a) @(F a :** F a) \x -> CCC.do+  y <- id -< x+  y ** y++{- HLINT ignore first "Use fst" -}+first :: forall {k} (a :: k) b. (HasProducts k, Ob a, Ob b) => (a && b) ~> a+first = toCCC @(F a :** F b) @(F a) \(a, _) -> a++-- Endofunctors have composition as their tensor. This arrow instead curries with respect+-- to their pointwise products, using Closed (PROD (Type -> Type)).+pairIdentities :: Nat Identity (Identity :~>: Product Identity Identity)+pairIdentities = CCC.curryPair @Identity @Identity++-- The outer variable is used at two binding depths.+captureTwice :: Bool -> Bool -> ((Bool, Bool), Bool)+captureTwice =+  toCCC @(F Bool) @(F Bool :-> ((F Bool :** F Bool) :** F Bool)) \x ->+    let f = CCC.lam (\y -> CCC.recast x ** y)+    in CCC.lam (\z -> (f CCC.! z) ** x)++arrowPair :: (Bool, Bool) -> (Bool, Bool)+arrowPair = toCCC @(F Bool :** F Bool) @(F (Bool, Bool)) \(x, y) -> CCC.do+  z <- not -< x+  returnA -< (z, y)++liftedNested :: ((Int, Int), Int) -> ((Int, Int), Int)+liftedNested = toCCC @((F Int :** F Int) :** F Int) @(F ((Int, Int), Int)) \((x, y), z) ->+  liftF returnA ((z, y), x)++arrowResultPair :: Int -> (Int, Int)+arrowResultPair = toCCC1 \z -> CCC.do+  (x, y) <- (\n -> (n + 1, n + 2)) -< z+  returnA -< (y, x)++arrowResultNested :: Int -> ((Int, Int), Int)+arrowResultNested = toCCC1 \z -> CCC.do+  (x, y, t) <- (\n -> ((n + 1, n + 2), n + 3)) -< z+  returnA -< (t, x, y)++reuseAcrossBinds :: Int -> ((Int, Int), (Int, Int))+reuseAcrossBinds = toCCC1 \n -> CCC.do+  x <- (+ 1) -< n+  y <- (* 2) -< x+  z <- uncurry (-) -< (x, n)+  returnA -< ((n, x), (y, z))++captureApplied :: Int -> (Int -> (Int, Int), Int)+captureApplied = toCCC1 \x -> CCC.do+  f <- CCC.lam @_ @_ @(F Int) (\y -> returnA -< (x, y))+  returnA -< (f, x)++embeddedSum :: Either Int Bool -> Int+embeddedSum = toCCC1 \s ->+  CCC.caseOf s ((+ 1) -<) ((\v -> if v then 10 else 20) -<)++embeddedFunction :: (Int -> Int, Int) -> Int+embeddedFunction = toCCC @(F (Int -> Int) :** F Int) @(F Int) (uncurry (!))++liftedFunction :: (Int, Int) -> Int+liftedFunction = toCCC @(F Int :** F Int) @(F Int) \(x, y) -> ((+) -< x) ! y++test :: TestTree+test =+  testGroup+    "CCC"+    [ testClosed @(PROD Type) (\r -> r) (\r -> r)+    , testProperty "arrow application to terms and tuples" $ do+        expect "term then pair" (False, True) (arrowPair (True, True))+        expect "liftF assembles a nested tuple" ((3, 2), 1) (liftedNested ((1, 2), 3))+    , testProperty "arrow application binds tensor results" $ do+        expect "pair result" (12, 11) (arrowResultPair 10)+        expect "nested result" ((13, 11), 12) (arrowResultNested 10)+    , testProperty "arrow application reuses variables across binds and nested scopes" $ do+        let n = 3+        expect "mixed depths" ((n, n + 1), (2 * (n + 1), 1)) (reuseAcrossBinds n)+        let (f, original) = captureApplied n+        expect "captured variable" ((n, 7), n) (f 7, original)+    , testProperty "case analysis on a sum embedded by F" $ do+        expect "left payload" 4 (embeddedSum (Left 3))+        expect "right payload" 10 (embeddedSum (Right True))+        expect "right alternative" 20 (embeddedSum (Right False))+    , testProperty "products, lifting and do binding" $ do+        mapM_ (\x -> expect ("duplicate " ++ show x) (x, x) (duplicate @Bool x)) ([False, True] :: [Bool])+        mapM_+          (\p@(x, _) -> expect ("first " ++ show p) x (first @Bool @Bool p))+          [(x, y) | x <- [False, True], y <- [False, True]]+    , testProperty "product swap" $+        expect "swap" (False, True) (CCC.swapProduct @Bool @Bool (True, False))+    , testProperty "application and currying" $ do+        expect "application" False (CCC.applyPair @Bool @Bool (not, True))+        expect "currying" (True, False) (CCC.curryPair @Bool @Bool True False)+    , testProperty "application accepts embedded and lifted functions" $ do+        expect "embedded function" 7 (embeddedFunction ((+ 3), 4))+        expect "lifted function" 7 (liftedFunction (3, 4))+    , testProperty "nested lambdas with a repeated argument" $+        mapM_+          (\(a, b) -> expect ("arguments " ++ show (a, b)) a (CCC.flipCurried3 @Bool @Bool @Bool (\x y z -> y && (x == z)) a b))+          [(a, b) | a <- [False, True], b <- [False, True]]+    , testProperty "a variable captured at two depths" $+        expect "capture" ((True, False), True) (captureTwice True False)+    , testProperty "injections and case analysis" $ do+        expect "right injection" (Right True) (CCC.injectRight @Bool @Bool True)+        expect "swap left" (Right True) (CCC.swapSum @Bool @Bool (Left True))+        expect "swap right" (Left False) (CCC.swapSum @Bool @Bool (Right False))+    , testProperty "case analysis shares the surrounding functions" $ do+        expect "left branch" False (CCC.caseEither @Bool @Bool @Bool (Left True, (not, id)))+        expect "right branch" True (CCC.caseEither @Bool @Bool @Bool (Right True, (not, id)))+    , testProperty "product exponentials in a category with composition tensor" $+        case unNat pairIdentities (Identity True) of+          Exp f -> expect "pointwise pair" (Pair (Identity True) (Identity False)) (f id (Identity False))+    ]
test/Examples/Cbpv.hs view
@@ -16,9 +16,10 @@ import Proarrow.Category.Monoidal (Monoidal (..)) import Proarrow.Category.Monoidal.Dialogue (Dialogue (..)) import Proarrow.Core (CategoryOf (..))-import Proarrow.Testing (check)-import Proarrow.Tools.SMC (SYN (F, I, (:**)), Up, dup, force, lam, lift, ret, thunk, toSMC, unit, (!), (**))+import Proarrow.Testing (check, expect)+import Proarrow.Tools.SMC (SYN (F, I, (:**)), Up, dup, force, lam, lift, ret, thunk, toSMC, unit, (!), (**), (-<)) import Proarrow.Tools.SMC qualified as SMC+import Proarrow.Tools.SMC.Examples (bindT)  -- | The category: functions, with the actions @m ()@ as the answer object. type K m = CPS (m () :: Type)@@ -46,7 +47,7 @@  -- | A constant. val :: forall m a d. a -> SMC.Term d '[] (V m a)-val a = lift @I @(V m a) (Cps (const a)) unit+val a = Cps (const a) -< unit  -- | Run a closed computation: give its result to a final continuation. run :: (Unit ~> Dual (Dual (C a :: K m))) -> (a -> m ()) -> m ()@@ -65,7 +66,7 @@   ret s'  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 (+)))+plus p = Cps (uncurry (+)) -< p  -- | Two computations made in one order and run in the other. A computation is a value until it is -- bound, so the effects happen in the order of the binds, not in the order the actions were@@ -125,6 +126,13 @@           ( logOf (addT (tell "read x" >> pure 1) (tell "read y" >> pure 2) tell) (("return " ++) . show)               == ["read x", "read y", "sum 3", "return 3"]           )+    , testProperty "ret assembles values reused across computation binds" $ do+        let program = toSMC @I @(Up (V W Int :** V W Int)) \() -> SMC.do+              x <- act (tell "read x" >> pure 5)+              () <- effect (tell . show) x+              y <- act (tell "read y" >> pure 8)+              ret (x, y)+        expect "values and effects" ["read x", "5", "read y", "(5,8)"] (logOf program show)     , testProperty "computations are values: made in one order, run in the other" $         check "wrong effects" (logOf (reversedT (tell "a") (tell "b")) (const "done") == ["b", "a", "done"])     , testProperty "a stored computation is bound without running, and runs at each force" $@@ -133,4 +141,14 @@         check "wrong effects" (logOf (droppedT (tell "never")) (const "done") == ["done"])     , testProperty "a function's effect happens at each application" $         check "wrong effects" (logOf (twiceT (tell . ("say " ++) . show)) (const "done") == ["say 1", "say 2", "done"])+    , testProperty "bind accepts an embedded computation as its continuation result" $ do+        let step :: (C Int :: K W) ~> Dual (Dual (C Int :: K W))+            step = Cps \n k -> tell ("step " ++ show n) >> k (n + 1)+            source k = tell "source" >> k 2 >> tell "between" >> k 3+            Cps bound = bindT step+            (calls, ()) = bound source (tell . ("return " ++) . show)+        expect+          "effect order and repeated continuation calls"+          ["source", "step 2", "return 3", "between", "step 3", "return 4"]+          calls     ]
+ test/Examples/Circuit.hs view
@@ -0,0 +1,370 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}++-- | A four-bit counter with enable and synchronous reset, built from Boolean gates and registers.+module Examples.Circuit+  ( test+  , Word4+  , increment+  , mux4+  , register4+  , counter+  , fromInt+  , toInt+  , demoInputs+  , demoOutputs+  , counterPicture+  , expandedCounterPicture+  , simplifiedCounterPicture+  , waveform+  , counterTestbench+  ) where++import Data.Bits (testBit)+import Data.List (isInfixOf)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Instance.Circuit+import Proarrow.Category.Instance.OpenHypergraph qualified as HG+import Proarrow.Category.Instance.Simulator (runSimulator)+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal.Strength (Costrong (..), TracedMonoidal)+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CategoryOf (..), Promonad (..), obj)+import Proarrow.Functor qualified as F+import Proarrow.Monoid (CocommutativeComonoid, Comonoid (..))+import Proarrow.Testing (check, expect, genNamed)+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.SMC (SYN (..), returnA, toSMC, unit, (-<))+import Proarrow.Tools.SMC qualified as SMC+import Props.Hask ()++-- In GHCi, from the repository root:+--+-- cabal repl test+-- import Examples.Circuit+-- demoOutputs+-- writeFile "/tmp/counter.svg" counterPicture+-- writeFile "/tmp/counter-expanded.svg" expandedCounterPicture+-- either fail (writeFile "/tmp/counter-simplified.svg") simplifiedCounterPicture+-- either (fail . show) (writeFile "/tmp/waveform.svg") waveform+-- writeFile "/tmp/counter.dot" (toDot (netlist counter))+-- :! dot -Tsvg /tmp/counter.dot -o /tmp/gates.svg+-- either (fail . show) (writeFile "/tmp/counter.v") (toVerilog "counter" (netlist counter))+-- either (fail . show) (writeFile "/tmp/counter_tb.v") counterTestbench+-- :! iverilog -g2012 -s tb -o /tmp/counter_sim /tmp/counter.v /tmp/counter_tb.v+-- :! vvp /tmp/counter_sim+--+-- The compact diagram uses one wire per word, labelled b₁ for control bits and b₄ for four-bit words.+-- Expanded ports are ordered enable, reset on the input and least-significant bit first on the output.++type Word4 :: Wires+type Word4 = Bit ** Bit ** Bit ** Bit++type Word4S :: k -> SYN k+type Word4S b = F b :** F b :** F b :** F b++-- | Ripple carries through the lower bits; overflow is discarded.+increment :: Word4 ~> Word4+increment = incrementWith @Bit (constant True) xorGate andGate++-- Inlining these SMC builders at each target makes GHC 9.12 spend excessive time simplifying.+{-# NOINLINE incrementWith #-}+incrementWith+  :: forall {k} (b :: k)+   . (CocommutativeComonoid b)+  => (Unit ~> b) -> (b ** b ~> b) -> (b ** b ~> b) -> b ** b ** b ** b ~> b ** b ** b ** b+incrementWith high xorG andG = toSMC @(Word4S b) @(Word4S b) \(a, b, c, d) -> SMC.do+  (a', carry1) <- SMC.recast @_ @(F b :** F b) (halfAdder -< (a, high -< unit))+  (b', carry2) <- SMC.recast @_ @(F b :** F b) (halfAdder -< (b, carry1))+  (c', carry3) <- SMC.recast @_ @(F b :** F b) (halfAdder -< (c, carry2))+  a' SMC.** b' SMC.** c' SMC.** (xorG -< (d, carry3))+  where+    halfAdder :: b ** b ~> b ** b+    halfAdder = toSMC @(F b :** F b) @(F b :** F b) \(a, b) ->+      (xorG -< (a, b)) SMC.** (andG -< (a, b))++mux4 :: Bit ** Word4 ** Word4 ~> Word4+mux4 = mux4With @Bit mux++-- Keep the SMC expansion shared, as for incrementWith.+{-# NOINLINE mux4With #-}+mux4With+  :: forall {k} (b :: k)+   . (CocommutativeComonoid b)+  => (b ** b ** b ~> b) -> b ** (b ** b ** b ** b) ** (b ** b ** b ** b) ~> b ** b ** b ** b+mux4With select = toSMC @(F b :** Word4S b :** Word4S b) @(Word4S b) \(s, (a, b, c, d), (w, x, y, z)) ->+  (select -< (s, a, w)) SMC.** (select -< (s, b, x)) SMC.** (select -< (s, c, y)) SMC.** (select -< (s, d, z))++register4 :: Int -> Word4 ~> Word4+register4 n = register a ** register b ** register c ** register d+  where+    (((a, b), c), d) = fromInt n++zero4 :: Empty ~> Word4+zero4 = zero4With @Bit (constant False)++zero4With :: forall {k} (b :: k). (CocommutativeComonoid b) => (Unit ~> b) -> Unit ~> b ** b ** b ** b+zero4With low = toSMC @I @(Word4S b) \() -> SMC.do+  z <- low -< unit+  z SMC.** z SMC.** z SMC.** z++-- | Enable holds or increments the count. Synchronous reset has priority over enable.+-- The initial output is zero; controls determine the output after the next clock edge.+counter :: Bit ** Bit ~> Word4+counter = counterWith @Bit @Word4 zero4 mux4 increment (register4 0)++counterWith+  :: forall {k} (b :: k) w+   . (TracedMonoidal k, CocommutativeComonoid w, Ob b)+  => (Unit ~> w) -> (b ** w ** w ~> w) -> (w ~> w) -> (w ~> w) -> b ** b ~> w+counterWith zero select inc delay = toSMC @(F b :** F b) @(F w) \(enable, reset) -> SMC.do+  rec count <- delay -< (select -< (reset, zero -< unit, select -< (enable, inc -< count, count)))+  returnA -< count++-- | The same counter with word-sized components, rather than their expanded bit-level gates.+counterPicture :: String+counterPicture = render (counterWith @Control @Bus (node "0") (node "mux4") (node "increment") (node "D4 (0)"))++-- | The same counter expanded into individual Boolean gates and one-bit registers.+expandedCounterPicture :: String+expandedCounterPicture =+  render $+    counterWith @Control @(Control ** Control ** Control ** Control)+      (zero4With @Control (node "0"))+      (mux4With @Control (node "MUX"))+      (incrementWith @Control (node "1") (node "XOR") (node "AND"))+      (delay ** delay ** delay ** delay)+  where+    delay :: Control ~> Control+    delay = node "D (0)"++-- | The expanded counter read back in parallel layers using traced copy/discard wiring.+simplifiedCounterPicture :: Either String String+simplifiedCounterPicture = do+  Str diagram <- HG.simplify (HG.layered (HG.tracedWith HG.copyDiscard)) expandedCounterGraph+  pure (render diagram)++type GraphBit :: HG.SIMPLIFY SVG+type GraphBit = HG.Wires '[Control]++expandedCounterGraph :: GraphBit ** GraphBit ~> GraphBit ** GraphBit ** GraphBit ** GraphBit+expandedCounterGraph =+  counterWith @GraphBit @(GraphBit ** GraphBit ** GraphBit ** GraphBit)+    (zero4With @GraphBit (HG.prim0 (node "0")))+    (mux4With @GraphBit (HG.prim3 (node "MUX")))+    ( incrementWith @GraphBit+        (HG.prim0 (node "1"))+        (HG.prim2 (node "XOR"))+        (HG.prim2 (node "AND"))+    )+    (delay ** delay ** delay ** delay)+  where+    delay :: GraphBit ~> GraphBit+    delay = HG.prim1 (node "D (0)")++type Control :: SVG+type Control = S '[Wire "b₁"]+type Bus :: SVG+type Bus = S '[Wire "b₄"]++fromInt :: Int -> Sample Word4+fromInt n = (((testBit n 0, testBit n 1), testBit n 2), testBit n 3)++toInt :: Sample Word4 -> Int+toInt (((a, b), c), d) = sum [weight | (bit, weight) <- zip [a, b, c, d] [1, 2, 4, 8], bit]++demoInputs :: [(Bool, Bool)]+demoInputs = replicate 18 (True, False) ++ replicate 3 (False, False) ++ [(True, True)] ++ replicate 5 (True, False)++demoOutputs :: Either CircuitError [Int]+demoOutputs = map toInt <$> simulate counter demoInputs++-- | A self-checking Verilog testbench using the simulator's expected counter outputs.+counterTestbench :: Either CircuitError String+counterTestbench = draw <$> demoOutputs+  where+    draw ns =+      unlines $+        [ "module tb;"+        , "  reg clk = 0;"+        , "  reg enable, reset;"+        , "  wire [3:0] count;"+        , "  counter dut(.clk(clk), .in0(enable), .in1(reset),"+        , "    .out0(count[0]), .out1(count[1]), .out2(count[2]), .out3(count[3]));"+        , "  initial begin"+        ]+          ++ concat [cycleLines i controls n | (i, controls, n) <- zip3 [0 :: Int ..] demoInputs ns]+          ++ [ "    $display(\"Counter matches simulator for " ++ show (length ns) ++ " cycles\");"+             , "    $finish;"+             , "  end"+             , "endmodule"+             ]+    cycleLines i (enable, reset) n =+      [ "    enable = " ++ bit enable ++ "; reset = " ++ bit reset ++ ";"+      , "    #1; if (count !== 4'd" ++ show n ++ ") $fatal(1, \"cycle " ++ show i ++ ": got %d\", count);"+      , "    #1 clk = 1; #1 clk = 0;"+      ]+    bit False = "1'b0"+    bit True = "1'b1"++-- | A waveform of the counter outputs before each clock edge and the controls for that cycle.+waveform :: Either CircuitError String+waveform = draw <$> demoOutputs+  where+    draw ns =+      unlines $+        [ "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\""+            ++ show width+            ++ "\" height=\"300\" viewBox=\"0 0 "+            ++ show width+            ++ " 300\">"+        , "<style>text{font:12px monospace;fill:#1f2328}path,line{fill:none;stroke:#0969da;stroke-width:2}.grid{stroke:#d0d7de;stroke-width:1}</style>"+        , "<rect width=\"100%\" height=\"100%\" fill=\"white\"/>"+        , text 12 20 "Four-bit counter: values before each clock edge"+        ]+          ++ [ "<line class=\"grid\" x1=\"" ++ show (x i) ++ "\" y1=\"32\" x2=\"" ++ show (x i) ++ "\" y2=\"275\"/>"+             | i <- [0 .. length ns]+             ]+          ++ [text (x i + 8) 44 (show i) | i <- [0 .. length ns - 1]]+          ++ concat [row y name samples | (y, name, samples) <- rows ns]+          ++ [text 12 279 "count"]+          ++ [text (x i + 8) 279 (show n) | (i, n) <- zip [0 ..] ns]+          ++ ["</svg>"]+    width = 100 + 28 * length demoInputs+    x :: Int -> Int+    x i = 84 + 28 * i+    text a b s = "<text x=\"" ++ show (a :: Int) ++ "\" y=\"" ++ show (b :: Int) ++ "\">" ++ s ++ "</text>"+    rows ns =+      [(70, "enable", map fst demoInputs), (102, "reset", map snd demoInputs)]+        ++ [(134 + 32 * bit, "q" ++ show bit, map (`testBit` bit) ns) | bit <- [0 .. 3]]+    row y name samples = [text 12 (y + 5) name, "<path d=\"" ++ unwords (segments y samples) ++ "\"/>"]+    segments :: Int -> [Bool] -> [String]+    segments _ [] = []+    segments y (b : bs) = ("M " ++ show (x 0) ++ " " ++ show (level b)) : go 0 b bs+      where+        level v = if v then y - 8 else y + 8+        go i _ [] = ["H " ++ show (x (i + 1))]+        go i previous (v : vs) = ("H " ++ show (x (i + 1)) ++ if previous == v then "" else " V " ++ show (level v)) : go (i + 1) v vs++bits :: [Bool]+bits = [False, True]++badLoop :: Empty ~> Bit+badLoop = toSMC @I @(F Bit) \() -> SMC.do+  rec x <- notGate -< x+  returnA -< x++test :: TestTree+test =+  testGroup+    "Digital circuits"+    [ testProperty "Boolean gate truth tables" do+        let pairs = [(a, b) | a <- bits, b <- bits]+            triples = [((s, a), b) | s <- bits, a <- bits, b <- bits]+        expect "NOT" (Right (map not bits)) (simulate notGate bits)+        expect "AND" (Right (map (uncurry (&&)) pairs)) (simulate andGate pairs)+        expect "OR" (Right (map (uncurry (||)) pairs)) (simulate orGate pairs)+        expect "XOR" (Right (map (uncurry (/=)) pairs)) (simulate xorGate pairs)+        expect "MUX" (Right [if s then a else b | ((s, a), b) <- triples]) (simulate mux triples)+        expect "low" (Right [False, False]) (simulate (constant False) [(), ()])+        expect "high" (Right [True, True]) (simulate (constant True) [(), ()])+    , testProperty "wiring preserves grouped bundles, copies and discards" do+        let xs = [((a, b), c) | a <- bits, b <- bits, c <- bits]+            wire :: Bit ** Bit ** Bit ~> Bit ** Bit ** Bit+            wire = toSMC @(F Bit :** F Bit :** F Bit) @(F (Bit ** Bit ** Bit)) \(a, _b, c) -> returnA -< (c, a, c)+        expect "fan-out and unused input" (Right [((c, a), c) | ((a, _), c) <- xs]) (simulate wire xs)+        expect "associators" (Right xs) (simulate (associatorInv . associator @Wires @Bit @Bit @Bit) xs)+        expect "left unitors" (Right bits) (simulate (leftUnitor . leftUnitorInv @Wires @Bit) bits)+        expect "right unitors" (Right bits) (simulate (rightUnitor . rightUnitorInv @Wires @Bit) bits)+        expect+          "swap twice"+          (Right [(a, b) | a <- bits, b <- bits])+          (simulate (swap . swap @Wires @Bit @Bit) [(a, b) | a <- bits, b <- bits])+        expect "trace yanking" (Right bits) (simulate (coact @Tensor @Circuit @Bit (swap @Wires @Bit @Bit)) bits)+        expect "copy then discard" (Right bits) (simulate (leftUnitor . (counit @Bit ** obj @Bit) . comult @Bit) bits)+    , testProperty "registers delay inputs and start at their declared values" do+        xs <- genNamed @[Bool] "inputs"+        expect "initial false" (Right (take (length xs) (False : xs))) (simulate (register False) xs)+        expect "initial true" (Right (take (length xs) (True : xs))) (simulate (register True) xs)+        expect+          "two cascaded registers"+          (Right (take (length xs) (False : True : xs)))+          (simulate (register False . register True) xs)+    , testProperty "parallel registers update simultaneously" do+        let exchange :: Empty ~> Bit ** Bit+            exchange = toSMC @I @(F (Bit ** Bit)) \() -> SMC.do+              rec (a, b) <- (register False ** register True) -< (b, a)+              returnA -< (a, b)+        expect "exchange" (Right (take 8 (cycle [(False, True), (True, False)]))) (simulate exchange (replicate 8 ()))+    , testProperty "increment wraps and bundle multiplexers select all four bits" do+        expect+          "all increments"+          (Right [fromInt ((n + 1) `mod` 16) | n <- [0 .. 15]])+          (simulate increment (map fromInt [0 .. 15]))+        let xs = [((s, fromInt a), fromInt b) | s <- bits, a <- [0 .. 15], b <- [0 .. 15]]+        expect "all word selections" (Right [if s then a else b | ((s, a), b) <- xs]) (simulate mux4 xs)+    , testProperty "counter follows an independent clocked specification" do+        controls <- genNamed @[(Bool, Bool)] "enable/reset"+        let model _ [] = []+            model n ((enable, reset) : xs) = n : model (if reset then 0 else if enable then (n + 1) `mod` 16 else n) xs+        expect "counter" (Right (model 0 controls)) (fmap (map toInt) (simulate counter controls))+        expect "demo wraps, holds and resets" (Right ([0 .. 15] ++ [0, 1, 2, 2, 2, 2, 0, 1, 2, 3, 4])) demoOutputs+    , testProperty "observable combinational cycles are rejected before any samples run" do+        check+          "inverter feedback accepted"+          (case simulate badLoop [] of Left (CombinationalCycle ns) -> not (null ns); _ -> False)+        let bare :: Empty ~> Bit+            bare = toSMC @I @(F Bit) \() -> SMC.do+              rec x <- id @Circuit @Bit -< x+              returnA -< x+        check "unconnected feedback accepted" (case simulate bare [] of Left (CombinationalCycle _) -> True; _ -> False)+    , testProperty "multiplexer validation checks both data inputs" do+        let selectedConstant :: Empty ~> Bit+            selectedConstant = toSMC @I @(F Bit) \() -> SMC.do+              x <- badLoop -< unit+              mux -< (constant True -< unit, constant False -< unit, x)+        check+          "cycle in unselected input accepted"+          (case simulate selectedConstant [] of Left (CombinationalCycle _) -> True; _ -> False)+    , testProperty "unobservable feedback is omitted from the netlist" do+        let dead = toSMC @I @I \() -> SMC.do+              _unused <- badLoop -< unit+              unit+        expect "discarded loop" (Right [(), ()]) (simulate dead [(), ()])+    , testProperty "preparing composition and tensor agrees with composing prepared circuits" do+        xs <- genNamed @[Bool] "clock inputs"+        case (prepare (netlist (register False)), prepare (netlist (register True))) of+          (Right f, Right g) -> do+            expect "composition" (simulate (register False . register True) xs) (Right (runSimulator (F.fmap @Value (f . g)) xs))+            expect+              "tensor"+              (simulate (register False ** register True) (zip xs xs))+              (Right (runSimulator (F.fmap @Value (f ** g)) (zip xs xs)))+          _ -> check "valid registers rejected" False+    , testProperty "netlist and waveform artifacts contain the circuit" do+        let n = netlist counter+        check "no counter diagram" ("<svg" `isInfixOf` counterPicture && "increment" `isInfixOf` counterPicture)+        check+          "no expanded counter diagram"+          ("<svg" `isInfixOf` expandedCounterPicture && "XOR" `isInfixOf` expandedCounterPicture)+        check "no registers in netlist" ("Register False" `isInfixOf` renderNetlist n)+        check "no register in diagram" ("D 0" `isInfixOf` toDot n)+        check "no waveform" (case waveform of Right svg -> "<svg" `isInfixOf` svg && "count" `isInfixOf` svg; _ -> False)+    , testProperty "Verilog preserves ports and register initialization" do+        case toVerilog "counter" (netlist counter) of+          Left err -> check (show err) False+          Right source -> do+            check "missing counter interface" ("module counter(input wire clk, input wire in0, input wire in1," `isInfixOf` source)+            check "missing most-significant output" ("output wire out3" `isInfixOf` source)+            check "missing register initialization" (" = 1'b0;" `isInfixOf` source && "initial w" `isInfixOf` source)+            check "missing rising-edge register" ("always @(posedge clk)" `isInfixOf` source && " <= w" `isInfixOf` source)+        check "combinational loop accepted" (case toVerilog "bad" (netlist badLoop) of Left _ -> True; _ -> False)+        expect+          "empty interface"+          (Right "module empty(input wire clk);\nendmodule\n")+          (toVerilog "empty" (netlist (id @Circuit @Empty)))+    ]
test/Examples/Einsum.hs view
@@ -3,6 +3,7 @@ module Examples.Einsum where  import Data.List (isInfixOf)+import Test.Falsify (Property, testFailed) import Test.Tasty (TestTree, testGroup) import Test.Tasty.Falsify (testProperty) import Prelude hiding ((**))@@ -12,9 +13,11 @@   , SomeArrow   , SomeSort   , Wires+  , Wiring+  , frobenius+  , frobeniusWith   , openHypergraph   , readBack-  , readBackWith   , someArrow   ) import Proarrow.Category.Instance.OpenHypergraph qualified as OH@@ -24,6 +27,7 @@ import Proarrow.Object (SomeOf (..)) import Proarrow.Testing (check) import Proarrow.Tools.Diagrams.Svg (Options (..), SVG (..), Svg, W (..), defaultOptions, node, renderWith)+import Proarrow.Tools.Diagrams.Svg qualified as Svg import Proarrow.Tools.Einsum (Tensor, einsum)  -- | The wire of an index.@@ -106,29 +110,54 @@ drawRead :: Either String (Strictified '[] '[X "l", X "i"]) -> String drawRead = either error (draw . unStr) +ringGraph :: Wires '[] ~> (Wires '[X "l", X "i"] :: OPENHG SVG String)+ringGraph = 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 as einsum reads it back with the sizes of the matrices. ringSized :: String ringSized =   drawRead-    ( readBackWith-        matSize+    ( readBack+        (frobeniusWith 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]])+        ringGraph     )  -- | 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]]))+ringNaive = drawRead (readBack frobenius 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)] +-- Retain the grouping of tensor boxes while ignoring the routing between them.+contractionTree :: Svg.Diagram -> String+contractionTree = \case+  Svg.Node _ title _ _ -> title+  Svg.Seq a b -> join (contractionTree a) (contractionTree b)+  Svg.Beside a b -> join (contractionTree a) (contractionTree b)+  Svg.Trace _ d -> contractionTree d+  _ -> ""+  where+    join "" b = b+    join a "" = a+    join a b = "(" ++ a ++ "," ++ b ++ ")"++checkTree :: Wiring SVG -> String -> Property ()+checkTree wiring expected = case readBack wiring ringArrow ringGraph of+  Left err -> testFailed err+  Right (Str (Svg.Svg _ diagram)) -> check "contraction tree changed" (contractionTree diagram == expected)+ test :: TestTree test =   testGroup     "Einsum pictures"-    [ testProperty ("draws " ++ file) (check "not an SVG document" ("<svg" `isInfixOf` svg))-    | (file, svg) <- gallery ++ ringPictures-    ]+    ( [ testProperty ("draws " ++ file) (check "not an SVG document" ("<svg" `isInfixOf` svg))+      | (file, svg) <- gallery ++ ringPictures+      ]+        ++ [ testProperty "uniform sizes preserve the contraction tree" (checkTree frobenius "(((V,U),T),W)")+           , testProperty "matrix sizes preserve the contraction tree" (checkTree (frobeniusWith matSize) "((V,(U,T)),W)")+           ]+    )
+ test/Examples/FRP.hs view
@@ -0,0 +1,30 @@+module Examples.FRP (test) where++import Control.Arrow qualified as A+import FRP.Yampa qualified as Y+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Profunctor.Instance.Arrow (Arr (..))+import Proarrow.Testing (expect, genNamed)+import Props.Mat ()+import SmcAudio (echo, echoWith)++test :: TestTree+test =+  testGroup+    "FRP audio (Yampa)"+    [ testProperty "an impulse produces regularly spaced, decaying echoes" $+        expect+          "echo samples"+          [1, 0, 0.5, 0, 0.25, 0, 0.125, 0]+          (Y.embed (echo 0.25 0.5) (Y.deltaEncode 0.125 [1, 0, 0, 0, 0, 0, 0, 0]))+    , testProperty "one-sample feedback follows the echo recurrence" $ do+        n <- genNamed @Int "input"+        let xs :: [Double]+            xs = map fromIntegral [n `mod` 11, 0, 3, -2, 0, 0]+            sf = unArr (echoWith (Arr (A.arr (\(dry, wet) -> dry + 0.5 * wet))) (Arr (Y.iPre 0)))+            expected = drop 1 (scanl (\previous input -> input + 0.5 * previous) 0 xs)+        expect "feedback samples" expected (Y.embed sf (Y.deltaEncode 1 xs))+    ]
+ test/Examples/Learning.hs view
@@ -0,0 +1,441 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoStarIsType #-}++-- | Learning with differentiable maps: a model is a parametrised arrow of+-- "Proarrow.Category.Instance.Diff", written with "Proarrow.Tools.SMC", its loss is the model+-- followed by the squared error, and the reverse derivative of the loss gives the gradient of the+-- parameters. An optimiser is a lens onto the parameters in its state, as in Cruttwell, Gavranović,+-- Ghani, Wilson and Zanasi, /Categorical Foundations of Gradient-Based Learning/: its view gives+-- the parameters and its update takes the gradient to the next state, which for momentum also+-- holds a velocity.+--+-- The models work on batches: a batch of @b@ inputs is a matrix with the inputs as its rows, and the+-- loss of a batch is the sum of the losses of its samples, so its gradient adds up theirs. A layer's+-- weights are a matrix from its inputs to its outputs, with a row for each input.+--+-- * Linear regression recovers the coefficients of a linear function from its values.+-- * A perceptron with one hidden layer learns exclusive or, which no linear model can, and with+--   momentum it does so in far fewer passes.+-- * A classifier with a softmax output tells apart three rings of points around the origin,+--   trained with the cross-entropy, and classifies points of the rings it has not seen.+-- * Self-attention learns to give every position of a sequence its largest value, by weighting the+--   positions with the softmax of query and key scores. The scores are a bilinear map, given as a+--   tensor network.+module Examples.Learning (test, scores, attentionPicture, attentionWiringPicture) where++import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Vector.Storable qualified as SV+import GHC.TypeNats (KnownNat, Nat, type (*))+import Test.Falsify (Property)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, mappend, (**), (.))++import Proarrow.Category.Instance.Diff+  ( DIFF (..)+  , Point (..)+  , add+  , append+  , backward+  , bilinear+  , broadcast+  , coordinates+  , forward+  , fromCoordinates+  , matMat+  , pointwise+  , scale+  , softmax+  , softmaxCrossEntropy+  , split+  , zero+  , pattern Vector+  )+import Proarrow.Category.Instance.Diff qualified as Diff+import Proarrow.Category.Instance.Opposite (OPPOSITE (..))+import Proarrow.Category.Instance.TensorNetwork (TNET (..), dimsOf)+import Proarrow.Category.Monoidal (Monoidal (..), SymMonoidal)+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Hypergraph (Frobenius)+import Proarrow.Category.Monoidal.Strength (first')+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->))+import Proarrow.Monoid (Monoid (..))+import Proarrow.Object (KnownListOf)+import Proarrow.Optic.Lens (Lens', lens, withLens)+import Proarrow.Promonad.Reader (Reader (..))+import Proarrow.Testing (check)+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.SMC (SYN (..), Term, delta, toSMC, (**), (*^), (-<))+import Proarrow.Tools.SMC qualified as SMC++type R1 :: DIFF+type R1 = DF '[1]++type R2 :: DIFF+type R2 = DF '[2]++type R3 :: DIFF+type R3 = DF '[3]++type R4 :: DIFF+type R4 = DF '[4]++-- | A batch of @b@ vectors of dimension @n@, the rows of a matrix.+type Batch :: Nat -> Nat -> DIFF+type Batch n b = DF '[b * n]++-- | An arrow from @a@ to @b@ with a parameter @x@, @x ** a ~> b@.+type Para :: forall {k}. k -> k +-> k+type Para x = Reader (OP x)++-- * Building blocks++-- | The sum of two terms.+plus+  :: forall n d g1 g2+   . (KnownNat n, SMC.Merge g1 g2)+  => Term d g1 (F (DF '[n])) -> Term d g2 (F (DF '[n])) -> Term d (SMC.Union g1 g2) (F (DF '[n]))+plus a b = mappend -< (a, b)++-- | The dot product of two terms.+dot+  :: forall n d g1 g2+   . (KnownNat n, SMC.Merge g1 g2) => Term d g1 (F (DF '[n])) -> Term d g2 (F (DF '[n])) -> Term d (SMC.Union g1 g2) (F R1)+dot a b = Diff.dot @n -< (a, b)++-- | @tanh@ on each coordinate of a term.+tanhT :: (KnownNat n) => Term d g (F (DF '[n])) -> Term d g (F (DF '[n]))+tanhT x = (pointwise tanh \y -> 1 - tanh y * tanh y) -< x++-- * Training++-- | Weights from @n@ inputs to @m@ outputs applied to each of a batch of vectors.+layer+  :: forall m n b d g1 g2+   . (KnownNat m, KnownNat n, KnownNat b, KnownNat (n * m), KnownNat (b * n), KnownNat (b * m), SMC.Merge g1 g2)+  => Term d g1 (F (Batch n b)) -> Term d g2 (F (DF '[n * m])) -> Term d (SMC.Union g1 g2) (F (Batch m b))+layer x w = matMat @b @n @m -< (x, w)++-- | An affine layer on a batch of vectors: weights from @n@ inputs to @m@ outputs applied to each vector, plus+-- an offset.+affineLayer+  :: forall m n b d g1 g2 g3+   . ( KnownNat m+     , KnownNat n+     , KnownNat b+     , KnownNat (n * m)+     , KnownNat (b * n)+     , KnownNat (b * m)+     , SMC.Merge g1 g2+     , SMC.Merge (SMC.Union g1 g2) g3+     )+  => Term d g1 (F (Batch n b))+  -> Term d g2 (F (DF '[n * m]))+  -> Term d g3 (F (DF '[m]))+  -> Term d (SMC.Union (SMC.Union g1 g2) g3) (F (Batch m b))+affineLayer x w c = plus (layer @m @n @b x w) (broadcast @m @b -< c)++-- | The sum of the squared differences of predictions and targets.+squaredError :: forall n. (KnownNat n) => DF '[n] ** DF '[n] ~> R1+squaredError = toSMC @(F (DF '[n]) :** F (DF '[n])) \(prediction, target) -> SMC.do+  d <- plus prediction (pointwise negate (const (-1)) -< target)+  dot d d++-- | The loss of a model on a batch, inputs and targets: the model, with the targets passed+-- alongside by its strength, followed by the given error of its outputs against the targets.+loss+  :: forall p a n. (Ob p, Ob a, KnownNat n) => DF '[n] ** DF '[n] ~> R1 -> Para p a (DF '[n]) -> Para p (a ** DF '[n]) R1+loss err model = rmap err (first' @(DF '[n]) model)++-- | Samples of an input and a target, in batches of @b@: the inputs as the rows of a matrix, and the+-- targets as the rows of another. Samples that do not fill a batch are left out.+batches :: forall n k b. (KnownNat b) => [Point '[n, k]] -> [Point '[b * n, b * k]]+batches samples = case splitAt b samples of+  (chunk, rest) | length chunk == b -> batch chunk : batches @n @k @b rest+  _ -> []+  where+    b = sum (dimsOf @'[b])+    batch chunk = let (xs, ts) = unzip [(x, t) | Point [x, t] <- chunk] in Point [SV.concat xs, SV.concat ts]++-- | The change of the parameters that increases the loss fastest, at a sample.+gradient+  :: forall ps as+   . (KnownListOf KnownNat ps, KnownListOf KnownNat as) => Para (DF ps) (DF as) R1 -> Point ps -> Point as -> Point ps+gradient (Reader f) w x = fst (split @ps @as (backward f (append w x) (Vector (SV.singleton 1))))++-- | The outputs of a model with the given parameters.+predict :: Para (DF ps) (DF as) (DF bs) -> Point ps -> Point as -> Point bs+predict (Reader f) w x = forward f (append w x)++-- | An optimiser: a lens onto the parameters in its state. Its view gives the parameters to run+-- the model with, and its update takes the gradient there to the next state.+type Optimiser :: Type -> [Nat] -> Type+type Optimiser s ps = Lens' s (Point ps)++-- | Gradient descent with the given rate: the state is the parameters, and an update moves them+-- against the gradient.+gradientDescent :: Double -> Optimiser (Point ps) ps+gradientDescent rate = lens id \(w, dw) -> add w (scale (negate rate) dw)++-- | Gradient descent with momentum: the state also keeps a velocity, which each update decays by+-- the given factor and adds the gradient to, and the parameters move against the velocity.+momentum :: Double -> Double -> Optimiser (Point ps, Point ps) ps+momentum rate decay = lens snd \((v, w), dw) ->+  let v' = add (scale decay v) dw in (v', add w (scale (negate rate) v'))++-- | Training: one update of the optimiser for each batch, for the given number of passes over the+-- batches. The parameters of each update are computed before the next one starts, so that no chain+-- of unevaluated updates builds up.+train+  :: (KnownListOf KnownNat ps, KnownListOf KnownNat as)+  => Optimiser s ps -> Int -> Para (DF ps) (DF as) R1 -> s -> [Point as] -> s+train optimiser passes f start bs = withLens optimiser \params update ->+  let step st x = let st' = update (st, gradient f (params st) x) in foldr seq () (vectors (params st')) `seq` st'+      go 0 st = st+      go k st = go (k - 1) (foldl' step st bs)+  in go passes start++-- * Linear regression++-- | A linear function of three inputs, on a batch: weights, an offset and the inputs.+affine :: forall b. (KnownNat b, KnownNat (b * 3)) => Para (DF '[3, 1]) (Batch 3 b) (DF '[b])+affine = Reader (toSMC @(F R3 :** F R1 :** F (Batch 3 b)) \(w, c, x) -> affineLayer @1 @3 @b x w c)++-- | Samples of @x - 2y + z/2 + 0.3@ on a grid.+regressionSamples :: [Point '[3, 1]]+regressionSamples =+  [ Point [SV.fromList [x, y, z], SV.singleton (x - 2 * y + z / 2 + 0.3)]+  | x <- [-1, 0, 1]+  , y <- [-1, 0, 1]+  , z <- [-1, 0, 1]+  ]++-- * Exclusive or++-- | A hidden layer of two @tanh@ units and a @tanh@ output, on a batch: the hidden weights and+-- offsets, the output weights and offset, and the inputs.+perceptron :: forall b. (KnownNat b, KnownNat (b * 2)) => Para (DF '[4, 2, 2, 1]) (Batch 2 b) (DF '[b])+perceptron =+  Reader+    ( toSMC @(F R4 :** F R2 :** F R2 :** F R1 :** F (Batch 2 b)) \(w1, b1, w2, b2, x) -> SMC.do+        h <- tanhT (affineLayer @2 @2 @b x w1 b1)+        tanhT (affineLayer @1 @2 @b h w2 b2)+    )++-- | Exclusive or on -1 and 1.+xorSamples :: [Point '[2, 1]]+xorSamples = [Point [SV.fromList [x, y], SV.singleton (if x == y then -1 else 1)] | x <- [-1, 1], y <- [-1, 1]]++-- | All of exclusive or as one batch.+xorBatch :: [Point '[4 * 2, 4]]+xorBatch = batches @2 @1 @4 xorSamples++-- | Small weights that tell the two hidden units apart.+xorStart :: Point '[4, 2, 2, 1]+xorStart = Point [SV.fromList [0.5, 0.3, -0.4, 0.6], SV.fromList [0.1, -0.1], SV.fromList [0.7, -0.5], SV.singleton 0]++-- * Three rings++-- | Scores for three classes from two coordinates, on a batch: a hidden layer of eight @tanh@ units,+-- with its weights and offsets, and the output weights and offsets.+classifier+  :: forall b+   . (KnownNat b, KnownNat (b * 2), KnownNat (b * 8), KnownNat (b * 3)) => Para (DF '[16, 8, 24, 3]) (Batch 2 b) (Batch 3 b)+classifier =+  Reader+    ( toSMC @(F (DF '[16]) :** F (DF '[8]) :** F (DF '[24]) :** F (DF '[3]) :** F (Batch 2 b)) \(w1, b1, w2, b2, x) -> SMC.do+        h <- tanhT (affineLayer @8 @2 @b x w1 b1)+        affineLayer @3 @8 @b h w2 b2+    )++-- | Points on three rings around the origin, of radius about 0.3, 0.6 and 0.9, each with its ring as+-- a target that puts all probability on it. The @i@th point is on ring @i `mod` 3@, at @i@ times the+-- golden angle, so that the rings take turns and the points spread around them.+rings :: [Int] -> [Point '[2, 3]]+rings is =+  [ Point [SV.fromList [r * cos a, r * sin a], SV.generate 3 \c' -> if c' == c then 1 else 0]+  | i <- is+  , let c = i `mod` 3+        a = fromIntegral i * 2.39996+        r = 0.3 * fromIntegral (c + 1) + 0.05 * sin (fromIntegral i * 1.7)+  ]++-- | Small weights of both signs.+classifierStart :: Point '[16, 8, 24, 3]+classifierStart = fromCoordinates (SV.generate (sum (dimsOf @'[16, 8, 24, 3])) \i -> 0.5 * sin (fromIntegral (i * i + 1)))++-- | The share of the points that the classifier with the given parameters puts on their ring.+accuracy :: Point '[16, 8, 24, 3] -> [Point '[2, 3]] -> Double+accuracy w samples = fromIntegral (length (filter id hits)) / fromIntegral (length hits)+  where+    hits =+      [ SV.maxIndex (coordinates (predict (classifier @1) w x)) == SV.maxIndex t+      | (x, Vector t) <- map (split @'[2] @'[3]) samples+      ]++-- * Attention++-- | The wiring of @ik,jk->ij@: two matrices to the first times the transposed second, the scores+-- of each query against each key. It is all spiders, so it works with any index objects that are+-- Frobenius algebras: tensor networks for training, and string diagrams for drawing.+scores+  :: forall {c} (i :: c) j k+   . (SymMonoidal c, Frobenius k, Ob i, Ob j)+  => i ** k ** j ** k ~> i ** j+scores = toSMC @(F i :** F k :** F j :** F k) \(a, b, c, d) -> delta b d *^ (a ** c)++-- | The steps of single-head self-attention over a sequence @x@: projecting it with weights @w@ to+-- queries, keys or values @s@, weighing each query against each key, @a@, mixing the values with+-- those weights, and an output map with weights @wo@ to the result @o@.+type AttentionSteps :: forall {c}. c -> c -> c -> c -> c -> c -> Type+data AttentionSteps x w s a wo o = AttentionSteps+  { project :: x ** w ~> s+  , weigh :: s ** s ~> a+  , mix :: a ** s ~> s+  , output :: s ** wo ~> o+  }++-- | Single-head self-attention from its steps: the queries, keys and values are the sequence projected+-- with their own weights, the keys weigh the queries, and the weighted values go through the output+-- map. The parameters are the query, key, value and output weights.+attentionWith+  :: forall {c} (x :: c) w s a wo o+   . (CopyDiscard c, Ob x, Ob w, Ob s, Ob a, Ob wo, Ob o)+  => AttentionSteps x w s a wo o -> w ** w ** w ** wo ** x ~> o+attentionWith st = toSMC @(F w :** F w :** F w :** F wo :** F x) \(wq, wk, wv, wo, x) ->+  let q = project st -< (x, wq)+      k = project st -< (x, wk)+      v = project st -< (x, wv)+      a = weigh st -< (q, k)+  in output st -< (mix st -< (a, v), wo)++-- | Attention on sequences of four positions with two features each, and a number for each+-- position: queries, keys and values of dimension 4, the scores scaled by @1/2@ and their softmax for+-- each query.+attention :: Para (DF '[8, 8, 8, 4]) (DF '[8]) (DF '[4])+attention =+  Reader+    ( attentionWith @(DF '[8]) @(DF '[8]) @(DF '[16]) @(DF '[16]) @(DF '[4]) @(DF '[4])+        AttentionSteps+          { project = matMat @4 @2 @4+          , weigh =+              softmax @4 @4 . pointwise (/ 2) (const 0.5) . bilinear @'[4, 4] @'[4, 4] (scores @(TN '[4]) @(TN '[4]) @(TN '[4]))+          , mix = matMat @4 @4 @4+          , output = matMat @4 @4 @1+          }+    )++-- | Attention drawn with a box for each step, and a wire for each matrix: the sequence, the+-- weights, the queries, keys and values, the attention weights and the result.+attentionPicture :: String+attentionPicture =+  render+    ( attentionWith @(S '[Wire "X"]) @(S '[Wire "W"]) @(S '[Wire "H"]) @(S '[Wire "A"]) @(S '[Wire "Wₒ"]) @(S '[Wire "Y"])+        AttentionSteps+          { project = node "X·W"+          , weigh = node "softmax(Q·Kᵀ/√d)"+          , mix = node "A·V"+          , output = node "H·Wₒ"+          }+    )++-- | Attention drawn with a wire for each index: positions @i@, features @f@, the dimension @k@ of+-- queries and keys, and the output @o@, with the weighing opened up into the wiring of 'scores'.+attentionWiringPicture :: String+attentionWiringPicture =+  render+    ( attentionWith @(S '[Wire "i", Wire "f"]) @(S '[Wire "f", Wire "k"]) @(S '[Wire "i", Wire "k"])+        @(S '[Wire "i", Wire "i"])+        @(S '[Wire "k", Wire "o"])+        @(S '[Wire "i", Wire "o"])+        AttentionSteps+          { project = node "·W"+          , weigh =+              node @'[Wire "i", Wire "i"] "softmax"+                . node @'[Wire "i", Wire "i"] "/√d"+                . scores @(S '[Wire "i"]) @(S '[Wire "i"]) @(S '[Wire "k"])+          , mix = node "A·V"+          , output = node "·Wₒ"+          }+    )++-- | Sequences of four values between -1 and 1, spread around an offset of their own, each value+-- with the constant 1 as its second feature, and as target the largest value at every position.+sequences :: [Int] -> [Point '[8, 4]]+sequences ns =+  [ Point [SV.fromList (concat [[x, 1] | x <- xs]), SV.replicate 4 (maximum xs)]+  | n <- ns+  , let xs = [0.5 * sin (fromIntegral (7 * n + 3 * j) * 1.3) + 0.4 * sin (fromIntegral n * 2.1) | j <- [0 .. 3 :: Int]]+  ]++-- | Small weights of both signs.+attentionStart :: Point '[8, 8, 8, 4]+attentionStart = fromCoordinates (SV.generate (sum (dimsOf @'[8, 8, 8, 4])) \i -> 0.5 * sin (fromIntegral (i * i + 3)))++-- | The average distance between the prediction and the largest value, over all positions.+maxError :: Point '[8, 8, 8, 4] -> [Point '[8, 4]] -> Double+maxError w samples = sum errors / fromIntegral (length errors)+  where+    errors =+      [ abs (p - t)+      | (x, Vector ts) <- map (split @'[8] @'[4]) samples+      , (p, t) <- zip (SV.toList (coordinates (predict attention w x))) (SV.toList ts)+      ]++test :: TestTree+test =+  testGroup+    "Learning"+    [ testProperty "linear regression recovers the coefficients" do+        let w =+              coordinates (train (gradientDescent 0.02) 50 (loss squaredError (affine @9)) zero (batches @3 @1 @9 regressionSamples))+        check+          ("found " ++ show (SV.toList w))+          (SV.and (SV.zipWith (\a b -> abs (a - b) < 1e-3) w (SV.fromList [1, -2, 0.5, 0.3])))+    , testProperty "a perceptron learns exclusive or in batches of two" do+        learnsXor (train (gradientDescent 0.2) 200 (loss squaredError (perceptron @2)) xorStart (batches @2 @1 @2 xorSamples))+    , testProperty "from one batch, momentum learns in fifty passes, where plain gradient descent at the same rate stalls" do+        let still = xorLoss (train (gradientDescent 0.05) 50 (loss squaredError (perceptron @4)) xorStart xorBatch)+        check ("loss " ++ show still) (still > 0.01)+        learnsXor (snd (train (momentum 0.05 0.9) 50 (loss squaredError (perceptron @4)) (zero, xorStart) xorBatch))+    , testProperty "a classifier tells three rings apart, also on points it has not seen" do+        let w =+              snd+                ( train+                    (momentum 0.01 0.9)+                    100+                    (loss (softmaxCrossEntropy @3 @16) (classifier @16))+                    (zero, classifierStart)+                    (batches @2 @3 @16 (rings [0 .. 95]))+                )+            seen = accuracy w (rings [0 .. 95])+            unseen = accuracy w (rings [96 .. 191])+        check ("accuracy " ++ show seen) (seen == 1)+        check ("accuracy on unseen points " ++ show unseen) (unseen >= 0.95)+    , testProperty "attention learns to find the largest value, also in sequences it has not seen" do+        let w = snd (train (momentum 0.01 0.9) 200 (loss squaredError attention) (zero, attentionStart) (sequences [0 .. 63]))+            seen = maxError w (sequences [0 .. 63])+            unseen = maxError w (sequences [64 .. 127])+        check ("error " ++ show seen) (seen < 0.03)+        check ("error on unseen sequences " ++ show unseen) (unseen < 0.03)+    , testProperty "attention draws, with a box for each step and with the weighing as wiring" do+        check+          "not an SVG document"+          (and ["<svg" `isInfixOf` p | p <- [attentionPicture, attentionWiringPicture]])+    ]++-- | The loss of the perceptron with the given parameters on exclusive or.+xorLoss :: Point '[4, 2, 2, 1] -> Double+xorLoss w = sum [SV.head (coordinates (predict (loss squaredError (perceptron @4)) w s)) | s <- xorBatch]++-- | The perceptron with the given parameters has a small loss and gets every case right.+learnsXor :: Point '[4, 2, 2, 1] -> Property ()+learnsXor w = do+  let l = xorLoss w+      predictions = [(predict (perceptron @4) w inputs, targets) | (inputs, targets) <- map (split @'[4 * 2] @'[4]) xorBatch]+  check ("loss " ++ show l) (l < 0.01)+  check+    ("predicted " ++ show [SV.toList p | (Vector p, _) <- predictions])+    (and [SV.and (SV.zipWith (\q t -> signum q == t) p y) | (Vector p, Vector y) <- predictions])
test/Examples/LinearLogic.hs view
@@ -40,7 +40,7 @@ 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, cont, ret, toSMC, (|>), type (:##))+import Proarrow.Tools.SMC (SYN (F, Not, (:&&), (:**)), annihilate, cont, ret, toSMC, toSMC1, (-<), (|>), type (:##)) import Proarrow.Tools.SMC qualified as SMC import Proarrow.Tools.SMC.Examples   ( bothWaysT@@ -89,7 +89,7 @@           "differs from comult . h"           ( toSMC @(F F2) @(F F3 :** F F3)               ( \x -> SMC.do-                  y <- SMC.lift h x+                  y <- h -< x                   y SMC.** y               )               == comult . h@@ -98,7 +98,7 @@         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)+          ( toSMC @(F F2) @(F F3 :** F F3) (\x -> (h -< x) SMC.** (h -< x))               == (h ** h) . comult           )     , testProperty "a fed back variable of a rec block that is also used after it is copied" $@@ -115,13 +115,13 @@ -- 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)+  rec (b, u) <- (\(x, us) -> (take 3 us, x : us)) -< (a, 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)+recDropT = toSMC1 \a -> SMC.do+  rec (_b, u) <- (\(x, us) -> (take 3 us, x : us)) -< (a, u)   u  -- * Duals@@ -149,6 +149,23 @@           "differs"           ( toSMC @(F F2 :** F F1 :** F F3 :** F F2) (\(w, x, y, z) -> z SMC.** x SMC.** w SMC.** y)               == toSMC @(F F2 :** F F1 :** F F3 :** F F2) (\(((w, x), y), z) -> z SMC.** x SMC.** w SMC.** y)+          )+    , testProperty "a quintuple pattern is the left-nested pairs (FinRel 2, 1, 3, 2, 1)" $+        check+          "differs"+          ( toSMC @(F F2 :** F F1 :** F F3 :** F F2 :** F F1) (\(v, w, x, y, z) -> z SMC.** x SMC.** v SMC.** y SMC.** w)+              == toSMC @(F F2 :** F F1 :** F F3 :** F F2 :** F F1) (\((((v, w), x), y), z) -> z SMC.** x SMC.** v SMC.** y SMC.** w)+          )+    , testProperty "a sextuple bind is the left-nested pairs (FinRel 2, 1, 3, 2, 1, 2)" $+        check+          "differs"+          ( toSMC @(F F2 :** F F1 :** F F3 :** F F2 :** F F1 :** F F2)+              ( \t -> SMC.do+                  (u, v, w, x, y, z) <- t+                  z SMC.** x SMC.** u SMC.** y SMC.** w SMC.** v+              )+              == toSMC @(F F2 :** F F1 :** F F3 :** F F2 :** F F1 :** F F2)+                (\(((((u, v), w), x), y), z) -> z SMC.** x SMC.** u SMC.** y SMC.** w SMC.** v)           )     , testProperty "combineDual (FinRel 2, 3)" $         check "differs from combineDual" (combineDualT @F2 @F3 == combineDual @F2 @F3)
+ test/Examples/OpticDiagrams.hs view
@@ -0,0 +1,434 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE NoOverloadedLists #-}++-- | Two optics composed by graph substitution, following §10 of Wilson and Zanasi,+-- <https://arxiv.org/abs/2305.01041 Data-Parallel Algorithms for String Diagrams>.+-- Each source wire becomes a forward/backward pair. A generator becomes two boxes connected by+-- its residual. Graph composition connects the forward boxes in source order and the backward+-- boxes in reverse order. Moving the external backward wires gives an ordinary computation from+-- @(a⁺, c⁻)@ to @(c⁺, a⁻)@, with both residuals computed once and used by their backward boxes.+module Examples.OpticDiagrams (test, sourcePicture, encodedPicture, compositionPicture, derivativeSourcePicture, derivativePicture) where++import Data.Either (isLeft)+import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as M+import Data.Vector.Storable qualified as SV+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, mempty, (**), (.))++import Proarrow.Category.Instance.DecoratedCospan (DECCOSPAN (..), DecCospan (..))+import Proarrow.Category.Instance.Diff qualified as Diff+import Proarrow.Category.Instance.FinHask (FinHask (..))+import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Category.Instance.OpenHypergraph+  ( Box (..)+  , Boxes (..)+  , OPENHG+  , Port (..)+  , SomeArrow+  , SomeHypergraph (..)+  , SomeSort+  , WireSorts+  , Wires+  , box+  , frobenius+  , isomorphic+  , openHypergraph+  , readBack+  , sameSort+  , someArrow+  , sortList+  , substituteWith+  , unsafeOpenHypergraph+  )+import Proarrow.Category.Instance.Sub (Sub (..))+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor, SymMonoidal (..), Tensor)+import Proarrow.Category.Monoidal.Action (ActionAt)+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), obj)+import Proarrow.Functor qualified as Functor+import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Object (SomeOf (..), pattern Objs)+import Proarrow.Optic (Optic, Prostrong, iso, legs2prof)+import Proarrow.Optic.Action (ActFl, runMonoidalOptic)+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (Rep (..))+import Proarrow.Testing (check, expect, genNamed)+import Proarrow.Tools.Diagrams.Svg (SVG (..), Svg (..), W (Wire), node, render)+import Proarrow.Tools.Optic (OPTICS, optic, opticLegs, runOptics)+import Proarrow.Tools.SMC (SYN (F, Not, (:**)), annihilate, lift, produce, toSMC, toSMC1, (**), (-<))+import Proarrow.Tools.SMC qualified as SMC+import Props.Mat ()++data Gate = First | Second deriving (Eq, Show)+data Leg = Forward Gate | Backward Gate deriving (Eq, Show)++type A = S '[Wire "a"]+type B = S '[Wire "b"]+type C = S '[Wire "c"]+type AF = S '[Wire "a⁺"]+type AB = S '[Wire "a⁻"]+type BF = S '[Wire "b⁺"]+type BB = S '[Wire "b⁻"]+type CF = S '[Wire "c⁺"]+type CB = S '[Wire "c⁻"]+type MF = S '[Wire "m_f"]+type MG = S '[Wire "m_g"]+type Target = OPENHG SVG Leg++type Encoded = (Wires '[AF, AB] :: Target) ~> Wires '[CF, CB]+type Running = (Wires '[AF, CB] :: Target) ~> Wires '[CF, AB]++source :: (Wires '[A] :: OPENHG SVG Gate) ~> Wires '[C]+source = box @_ @'[B] @'[C] Second . box @_ @'[A] @'[B] First++objectMap :: SomeSort SVG -> [SomeSort SVG]+objectMap s+  | sameSort s (Some @A) = sortList @_ @'[AF, AB]+  | sameSort s (Some @B) = sortList @_ @'[BF, BB]+  | sameSort s (Some @C) = sortList @_ @'[CF, CB]+  | otherwise = error "objectMap: outside the example's signature"++-- The backward box's output meets the left boundary, and its input meets the right boundary.+generatorMap :: Gate -> SomeHypergraph SVG Leg+generatorMap First = opticBox @AF @AB @BF @BB @MF First+generatorMap Second = opticBox @BF @BB @CF @CB @MG Second++opticBox+  :: forall (a :: SVG) (da :: SVG) (b :: SVG) (db :: SVG) (m :: SVG)+   . (Ob a, Ob da, Ob b, Ob db, Ob m)+  => Gate -> SomeHypergraph SVG Leg+opticBox gate =+  SomeHypergraph $+    unsafeOpenHypergraph @Leg @'[a, da] @'[b, db]+      (sortList @_ @'[a, da, b, db, m])+      [0, 1]+      [2, 3]+      [Box (Forward gate) [0] [2, 4], Box (Backward gate) [4, 3] [1]]++encoded :: Either String Encoded+encoded = do+  SomeHypergraph graph <- substituteWith objectMap generatorMap source+  let (nodes, ins, outs, boxes) = parts graph+  openHypergraph nodes ins outs boxes++-- Backward wires have negative types; SMC supplies their duality bends.+running :: Either String Running+running = do+  graph <- encoded+  pure $ toSMC @(F (Wires '[AF]) :** Not (F (Wires '[CB]))) @(F (Wires '[CF]) :** Not (F (Wires '[AB]))) \(a, dc) -> SMC.do+    (da, da') <- produce @(F (Wires '[AB]))+    (c, dc') <- graph -< (a, da)+    () <- annihilate dc dc'+    c ** da'++parts :: forall l a b. (a :: OPENHG SVG l) ~> b -> ([SomeSort SVG], [Int], [Int], [Box l Int])+parts (DecCospan @c (Sub (FinHask l)) (Sub (FinHask r)) (Boxes boxes)) =+  (sortList @_ @(WireSorts (DC c)), fmap unPort (M.elems l), fmap unPort (M.elems r), fmap (fmap unPort) boxes)+  where+    unPort (Port i) = i++-- An independent description of the composite optic, with one residual node for each generator.+expected :: Running+expected =+  unsafeOpenHypergraph+    (sortList @_ @'[AF, AB, BF, BB, CF, CB, MF, MG])+    [0, 5]+    [4, 1]+    [ Box (Forward First) [0] [2, 6]+    , Box (Forward Second) [2] [4, 7]+    , Box (Backward Second) [7, 5] [3]+    , Box (Backward First) [6, 3] [1]+    ]++-- The same computation written as an SMC program, with the backward pass in reverse order.+scheduled :: Running+scheduled =+  composePasses @_ @(Wires '[AF]) @(Wires '[BF]) @(Wires '[CF]) @(Wires '[AB]) @(Wires '[BB]) @(Wires '[CB])+    @(Wires '[MF])+    @(Wires '[MG])+    (box @Leg @'[AF] @'[BF, MF] (Forward First))+    (box @Leg @'[BF] @'[CF, MG] (Forward Second))+    (box @Leg @'[MF, BB] @'[AB] (Backward First))+    (box @Leg @'[MG, CB] @'[BB] (Backward Second))++-- This program runs in the symbolic graph and in the writer used to count numerical evaluations.+composePasses+  :: forall {k} (p :: CAT k) (a :: k) (b :: k) (c :: k) (da :: k) (db :: k) (dc :: k) (m :: k) (n :: k)+   . (SymMonoidal k, Promonad p, MonoidalProfunctor p, Ob c, Ob dc, Ob m, Ob n)+  => p a (b ** m) -> p b (c ** n) -> p (m ** db) da -> p (n ** dc) db -> p (a ** dc) (c ** da)+composePasses forward1@Objs forward2@Objs backward1@Objs backward2@Objs =+  SMC.proc @(F a :** F dc) @(F c :** F da) \(a, dc) -> SMC.do+    (b, m) <- lift @(F a) @(F b :** F m) forward1 a+    (c, n) <- lift @(F b) @(F c :** F n) forward2 b+    db <- backward2 -< (n, dc)+    da <- backward1 -< (m, db)+    c ** da++-- | The source function of the derivative example: @x ↦ sin (x²)@.+derivativeSourcePicture :: String+derivativeSourcePicture = render (node @'[Wire "b"] @'[Wire "c"] "sin" . node @'[Wire "a"] @'[Wire "b"] "square")++-- | The substituted graph with concrete forward and reverse-derivative primitives.+-- The square saves x; the sine saves cos(x²). Neither forward operation is repeated backward.+derivativePicture :: Either String String+derivativePicture = running >>= drawGraph derivativeLeg++derivativeLeg :: Leg -> SomeArrow SVG+derivativeLeg = drawLeg \case+  Forward First -> "z = x²; save x"+  Forward Second -> "y = sin z; save cos z"+  Backward First -> "dx = 2x · dz"+  Backward Second -> "dz = cos z · dy"++runDerivative :: (Double, Double) -> ([String], (Double, Double))+runDerivative =+  Functor.unPrelude+    . unStar+      ( composePasses+          (Star (\x -> Functor.Prelude (["square"], (x * x, x))))+          (Star (\z -> Functor.Prelude (["sin"], (sin z, cos z))))+          (Star (\(x, dz) -> Functor.Prelude (["square backward"], 2 * x * dz)))+          (Star (\(cosZ, dy) -> Functor.Prelude (["sin backward"], cosZ * dy)))+      )++-- The source program uses ordinary SMC composition. Its optic primitives supply the residuals;+-- runOptics builds and substitutes the graph, then reads the numerical computation back.+derivativeFunction :: Either String ((Double, Double) -> (Double, Double))+derivativeFunction = runOptics derivativeProgram++type Number = Wires '[ '(Double, Double)] :: OPTICS Type++square :: Number ~> Number+square = opticLegs @Double (\x -> (x, x * x)) (\(x, dy) -> 2 * x * dy)++sine :: Number ~> Number+sine = opticLegs @Double (\x -> (cos x, sin x)) (uncurry (*))++parallel :: Number ** Number ~> Number ** Number+parallel = toSMC @(F Number :** F Number) \(x, y) -> SMC.do+  x' <- square -< x+  y' <- sine -< y+  x' ** y'++type Logged = KLEISLI (Star (Functor.Prelude ((,) [String])))+type LoggedWire = Wires '[ '(KL Double, KL Double)] :: OPTICS Logged++loggedProgram :: LoggedWire ~> LoggedWire+loggedProgram = toSMC1 \x -> SMC.do+  y <- f -< x+  g -< y+  where+    logged :: String -> (a -> b) -> (KL a :: Logged) ~> KL b+    logged name f' = Kleisli (Star (\a -> Functor.Prelude ([name], f' a)))+    f, g :: LoggedWire ~> LoggedWire+    f = opticLegs @(KL Double) (logged "square" (\x -> (x, x * x))) (logged "square backward" (\(x, dy) -> 2 * x * dy))+    g = opticLegs @(KL Double) (logged "sin" (\x -> (cos x, sin x))) (logged "sin backward" (uncurry (*)))++derivativeProgram :: Number ~> Number+derivativeProgram = toSMC1 \x -> SMC.do+  z <- square -< x+  sine -< z++reference :: Diff.Diff (Diff.DF '[1]) (Diff.DF '[1])+reference = Diff.pointwise @1 sin cos . Diff.pointwise @1 (\x -> x * x) (2 *)++close :: Double -> Double -> Bool+close expectedValue actual = abs (expectedValue - actual) <= 1e-8 * max 1 (abs expectedValue)++interpret :: Leg -> SomeArrow SVG+interpret = drawLeg \case+  Forward First -> "f forward"+  Forward Second -> "g forward"+  Backward First -> "f backward"+  Backward Second -> "g backward"++drawLeg :: (Leg -> String) -> Leg -> SomeArrow SVG+drawLeg name leg@(Forward First) = someArrow @'[AF] @'[BF, MF] (Str (node @'[Wire "a⁺"] @'[Wire "b⁺", Wire "m_f"] (name leg)))+drawLeg name leg@(Forward Second) = someArrow @'[BF] @'[CF, MG] (Str (node @'[Wire "b⁺"] @'[Wire "c⁺", Wire "m_g"] (name leg)))+drawLeg name leg@(Backward First) = someArrow @'[MF, BB] @'[AB] (Str (node @'[Wire "m_f", Wire "b⁻"] @'[Wire "a⁻"] (name leg)))+drawLeg name leg@(Backward Second) = someArrow @'[MG, CB] @'[BB] (Str (node @'[Wire "m_g", Wire "c⁻"] @'[Wire "b⁻"] (name leg)))++sourcePicture :: String+sourcePicture = render (node @'[Wire "b"] @'[Wire "c"] "g" . node @'[Wire "a"] @'[Wire "b"] "f")++encodedPicture :: Either String String+encodedPicture = encoded >>= drawGraph interpret++compositionPicture :: Either String String+compositionPicture = running >>= drawGraph interpret++drawGraph :: (Leg -> SomeArrow SVG) -> (a :: Target) ~> b -> Either String String+drawGraph draw graph = do+  Str picture@Svg{} <- readBack frobenius draw graph+  pure (render picture)++test :: TestTree+test =+  testGroup+    "Optic diagrams"+    [ testProperty "substitution agrees with the hand-built composite" $+        either testFailed (check "different wiring" . isomorphic expected) running+    , testProperty "substitution agrees with the SMC computation" $+        either testFailed (check "different wiring" . isomorphic scheduled) running+    , testProperty "compiling optics agrees with extracting the composite's legs" $ do+        let first :: Optic (Prostrong (ActFl Tensor)) (Wires '[AF] :: Target) (Wires '[AB]) (Wires '[BF]) (Wires '[BB])+            first =+              legs2prof @(ActFl Tensor)+                ( Rep @_ @(ActionAt Tensor (Wires '[MF]))+                    (swap @Target @(Wires '[BF]) @(Wires '[MF]) . box @Leg @'[AF] @'[BF, MF] (Forward First))+                )+                (Corep @_ @(ActionAt Tensor (Wires '[MF])) (box @Leg @'[MF, BB] @'[AB] (Backward First)))+            second :: Optic (Prostrong (ActFl Tensor)) (Wires '[BF] :: Target) (Wires '[BB]) (Wires '[CF]) (Wires '[CB])+            second =+              legs2prof @(ActFl Tensor)+                ( Rep @_ @(ActionAt Tensor (Wires '[MG]))+                    (swap @Target @(Wires '[CF]) @(Wires '[MG]) . box @Leg @'[BF] @'[CF, MG] (Forward Second))+                )+                (Corep @_ @(ActionAt Tensor (Wires '[MG])) (box @Leg @'[MG, CB] @'[BB] (Backward Second)))+            graph =+              optic @_ @'[ '(Wires '[BF], Wires '[BB])] @'[ '(Wires '[CF], Wires '[CB])] second+                . optic @_ @'[ '(Wires '[AF], Wires '[AB])] @'[ '(Wires '[BF], Wires '[BB])] first+            connected :: Running+            connected = runMonoidalOptic (first . second)+        compiled <- either testFailed pure (runOptics graph)+        check "different wiring" (isomorphic connected compiled)+    , testProperty "sin(x²) computes its value and reverse derivative" $ do+        i <- genNamed @Int "input"+        j <- genNamed @Int "cotangent"+        function <- either testFailed pure derivativeFunction+        let x = fromIntegral (i `mod` 25 - 12) / 4+            dy = fromIntegral (j `mod` 9 - 4) / 2+            (calls, (y, dx)) = runDerivative (x, dy)+            (graphY, graphDx) = function (x, dy)+            point = Diff.Vector (SV.singleton x)+            seed = Diff.Vector (SV.singleton dy)+            (referenceY, pullback) = Diff.run reference point+        expect+          "each primitive once, backward in reverse order"+          ["square", "sin", "sin backward", "square backward"]+          calls+        check "graph forward agrees with the SMC schedule" (close y graphY)+        check "graph backward agrees with the SMC schedule" (close dx graphDx)+        check "forward value" (close (sin (x * x)) y)+        check "chain rule" (close (2 * x * cos (x * x) * dy) dx)+        check "Diff forward" (close (SV.head (Diff.coordinates referenceY)) y)+        check "Diff backward" (close (SV.head (Diff.coordinates (pullback seed))) dx)+        let eps = 1e-6+            f t = sin (t * t)+            finiteDifference = (f (x + eps) - f (x - eps)) / (2 * eps)+        check "finite differences" (close (finiteDifference * dy) dx)+    , testProperty "derivative graph keeps one of each primitive" $+        either+          testFailed+          ( \graph ->+              let (_, _, _, boxes) = parts graph+                  legs = [Forward First, Backward First, Forward Second, Backward Second]+              in do+                   expect+                     "one of each primitive"+                     [1, 1, 1, 1]+                     [length (filter ((== leg) . label) boxes) | leg <- legs]+          )+          running+    , testProperty "source picture draws both generators" $+        check "missing source generators" (all (`isInfixOf` sourcePicture) [">f<", ">g<"])+    , testProperty "encoded picture draws the forward and backward boxes" $+        either+          testFailed+          ( \picture -> check "missing encoded boxes" (all (`isInfixOf` picture) ["f forward", "g forward", "f backward", "g backward"])+          )+          encodedPicture+    , testProperty "derivative source picture draws square and sine" $+        check "missing derivative generators" (all (`isInfixOf` derivativeSourcePicture) ["square", "sin"])+    , testProperty "derivative picture draws values, residuals and pullbacks" $+        either+          testFailed+          ( \picture ->+              check+                "missing derivative boxes"+                (all (`isInfixOf` picture) ["x²; save x", "sin z; save cos z", "2x · dz", "cos z · dy"])+          )+          derivativePicture+    , testProperty "both forward and backward boxes are drawn" $+        either+          testFailed+          (\picture -> check "missing boxes" (all (`isInfixOf` picture) ["f forward", "g forward", "f backward", "g backward"]))+          compositionPicture+    , testProperty "parallel SMC primitives keep both backward wires in order" $ do+        i <- genNamed @Int "x"+        j <- genNamed @Int "z"+        f <- either testFailed pure (runOptics parallel)+        let x = fromIntegral (i `mod` 7 - 3)+            z = fromIntegral (j `mod` 7 - 3)+            ((y, w), (dx, dz)) = f ((x, z), (2, 3))+        expect "forward square" (x * x) y+        expect "forward sine" (sin z) w+        expect "backward square" (4 * x) dx+        expect "backward sine" (3 * cos z) dz+    , testProperty "compiled computation executes each primitive once" $ do+        Kleisli f <- either testFailed pure (runOptics loggedProgram)+        let (calls, (y, dx)) = Functor.unPrelude (unStar f (2, 3))+        expect "order and multiplicity" ["square", "sin", "sin backward", "square backward"] calls+        expect "value" (sin 4) y+        check "derivative" (abs (12 * cos 4 - dx) < 1e-12)+    , testProperty "multi-output primitive supplies an SMC tuple pattern" $ do+        let duplicate :: Number ~> Number ** Number+            duplicate = opticLegs @() (\x -> ((), (x, x))) (\((), (dx, dy)) -> dx + dy)+            program = toSMC @(F Number) \x -> SMC.do+              (u, v) <- duplicate -< x+              a <- square -< u+              b <- sine -< v+              a ** b+        f <- either testFailed pure (runOptics program)+        let ((y, z), dx) = f (2, (1, 1))+        expect "two forward results" (4, sin 2) (y, z)+        expect "cotangents are added by the duplication optic" (4 + cos 2) dx+    , testProperty "nullary primitive has an empty source boundary" $ do+        let constant :: (Wires '[] :: OPTICS Type) ~> Wires '[ '(Int, Int)]+            constant = opticLegs @() (\() -> ((), 7)) (\((), _) -> ())+        f <- either testFailed pure (runOptics constant)+        expect "constant" (7, ()) (f ((), 5))+    , testProperty "multi-input primitive folds its source ports" $ do+        let multiply :: Number ** Number ~> Number+            multiply = opticLegs @(Double, Double) (\(x, y) -> ((x, y), x * y)) (\((x, y), dz) -> (y * dz, x * dz))+        f <- either testFailed pure (runOptics multiply)+        expect "product rule" (6, (12, 8)) (f ((2, 3), 4))+    , testProperty "primitive can have an empty target boundary" $ do+        let finish :: (Wires '[ '(Int, Int)] :: OPTICS Type) ~> Wires '[]+            finish = opticLegs @Int (,()) (\(x, ()) -> x + 1)+        f <- either testFailed pure (runOptics finish)+        expect "saved residual" ((), 9) (f (8, ()))+    , testProperty "different forward, backward and residual types" $ do+        let primitive :: (Wires '[ '(Int, String)] :: OPTICS Type) ~> Wires '[ '(Double, Char)]+            primitive = opticLegs @Bool (\n -> (even n, fromIntegral n / 2)) (\(evenN, c) -> replicate (if evenN then 1 else 2) c)+        f <- either testFailed pure (runOptics primitive)+        expect "even residual" (4, "x") (f (8, 'x'))+        expect "odd residual" (4.5, "yy") (f (9, 'y'))+    , testProperty "existing optic encoding" $ do+        let o :: Optic (Prostrong (ActFl Tensor)) Int String Double Char+            o = iso fromIntegral (replicate 2)+        f <- either testFailed pure (runOptics (optic @_ @'[ '(Int, String)] @'[ '(Double, Char)] o))+        expect "iso legs" (7, "zz") (f (7, 'z'))+    , testProperty "permutation reverses the backward boundary permutation" $ do+        let graph = swap @(OPTICS Type) @(Wires '[ '(Int, Bool)]) @(Wires '[ '(Double, Char)])+        f <- either testFailed pure (runOptics graph)+        expect "mixed permutation" ((2.5, 7), (True, 'z')) (f ((7, 2.5), ('z', True)))+    , testProperty "identity needs no primitives" $ do+        f <- either testFailed pure (runOptics (obj @Number))+        expect "identity" (3, 7) (f (3, 7))+    , testProperty "empty boundaries fold to the unit" $ do+        f <- either testFailed pure (runOptics (obj @(Wires '[] :: OPTICS Type)))+        expect "unit" ((), ()) (f ((), ()))+    , testProperty "copying requires stronger target wiring" $+        check "copy accepted" (isLeft (runOptics (comult @Number)))+    , testProperty "discarding requires stronger target wiring" $+        check "discard accepted" (isLeft (runOptics (counit @Number)))+    , testProperty "isolated feedback requires a trace" $+        check "feedback accepted" (isLeft (runOptics (counit @Number . mempty @Number)))+    ]
+ test/Examples/Parallel.hs view
@@ -0,0 +1,386 @@+{-# LANGUAGE QualifiedDo #-}++-- | A small build system: one SMC program supplies execution, diagrams and parallel scheduling.+module Examples.Parallel (test, demo, runSequential, runParallel, Run (..), Event (..), sequentialPicture, parallelPicture, timeline) where++import Control.Concurrent.Async qualified as Async+import Control.Concurrent.MVar (modifyMVar_, newMVar, readMVar)+import Control.Monad ((>=>))+import Data.Kind (Type)+import Data.List (isInfixOf, sort, sortOn)+import GHC.Clock (getMonotonicTimeNSec)+import System.Directory (createDirectory, createDirectoryIfMissing)+import System.Exit (ExitCode (..))+import System.FilePath (takeDirectory, takeFileName, (</>))+import System.IO (readFile')+import System.IO.Temp (withSystemTempDirectory)+import System.Process (readProcessWithExitCode)+import Test.Falsify (testFailed)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Text.Printf (printf)+import Prelude hiding (id, (**), (.))+import Prelude qualified as P++import Proarrow.Category.Instance.Kleisli (KLEISLI (..), Kleisli (..))+import Proarrow.Category.Instance.OpenHypergraph qualified as HG+import Proarrow.Category.Monoidal (Monoidal, MonoidalProfunctor, type (**))+import Proarrow.Category.Monoidal.Hypergraph (Sized (..))+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CategoryOf (..), Profunctor, Promonad (..))+import Proarrow.Functor (Prelude (..))+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Instance.Star (Star, pattern Star)+import Proarrow.Testing (expect)+import Proarrow.Tools.Diagrams.Svg (SVG (..), Svg (..), W (Wire), node, render)+import Proarrow.Tools.Diagrams.Svg qualified as Svg+import Proarrow.Tools.SMC (toSMC1, (-<))+import Proarrow.Tools.SMC qualified as SMC++-- In GHCi (requires ghc, haddock and tar on PATH):+--+-- cabal repl test+-- import Examples.Parallel+-- demo "/tmp/smc-build"+--+-- Jobs use isolated build directories and communicate through wires. Concurrent tensor with+-- sequential composition is not a lawful SMC for arbitrary IO with hidden shared-state effects.++-- * One pipeline, interpreted as functions, diagrams and concurrent jobs++buildGraph+  :: forall {k} (workspace :: k) sources object app executable documentation package+   . (Monoidal k)+  => (workspace ~> sources)+  -> (sources ~> object)+  -> (sources ~> object)+  -> (object ** object ~> app)+  -> (app ~> executable)+  -> (sources ~> documentation)+  -> (executable ** documentation ~> package)+  -> (HG.Wires '[workspace] :: HG.SIMPLIFY k) ~> HG.Wires '[package]+buildGraph prepare@Objs model@Objs view@Objs main@Objs link@Objs document@Objs package@Objs =+  toSMC1 \workspace -> SMC.do+    sources <- HG.prim1 prepare -< workspace+    modelObject <- HG.prim1 model -< sources+    viewObject <- HG.prim1 view -< sources+    app <- HG.prim2 main -< (modelObject, viewObject)+    executable <- HG.prim1 link -< app+    docs <- HG.prim1 document -< sources+    HG.prim2 package -< (executable, docs)++newtype Workspace = Workspace FilePath+newtype Sources = Sources FilePath+newtype Object = Object FilePath++-- An application contains Main.o together with its dependencies.+data App = App FilePath [FilePath]+newtype Executable = Executable FilePath+newtype Documentation = Documentation FilePath+newtype Package = Package FilePath++sourceFiles :: [(String, String)]+sourceFiles =+  [+    ( "Model"+    , unlines+        [ "-- | Sample data for the chart application."+        , "module Model where"+        , "-- | The values to plot."+        , "values :: [Int]"+        , "values = [4, 7, 2, 9]"+        ]+    )+  ,+    ( "View"+    , unlines+        [ "-- | Rendering the chart."+        , "module View where"+        , "-- | Draw one bar per value."+        , "chart :: [Int] -> String"+        , "chart ns = unlines [replicate n '#' | n <- ns]"+        ]+    )+  ,+    ( "Main"+    , unlines+        [ "-- | The chart application."+        , "module Main where"+        , "import Model"+        , "import View"+        , "main :: IO ()"+        , "main = putStr (chart values)"+        ]+    )+  ]++expected :: String+expected = "####\n#######\n##\n#########\n"++command :: FilePath -> [String] -> IO String+command program args = do+  (status, out, err) <- readProcessWithExitCode program args ""+  case status of+    ExitSuccess -> pure out+    ExitFailure code -> fail (unwords (program : args) ++ " failed (" ++ show code ++ ")\n" ++ out ++ err)++prepareSources :: Workspace -> IO Sources+prepareSources (Workspace root) = do+  createDirectory (root </> "src")+  mapM_ (\(name, text) -> writeFile (root </> "src" </> name ++ ".hs") text) sourceFiles+  pure (Sources root)++compileModule :: String -> Sources -> IO Object+compileModule name (Sources root) = do+  let output = root </> name+  createDirectory output+  _ <- command "ghc" ["-v0", "-O0", "-c", root </> "src" </> name ++ ".hs", "-odir", output, "-hidir", output]+  pure (Object (output </> name ++ ".o"))++compileMain :: (Object, Object) -> IO App+compileMain (Object model, Object view) = do+  let root = takeDirectory (takeDirectory model)+      output = root </> "Main"+  createDirectory output+  _ <-+    command+      "ghc"+      [ "-v0"+      , "-O0"+      , "-c"+      , root </> "src" </> "Main.hs"+      , "-i" ++ takeDirectory model+      , "-i" ++ takeDirectory view+      , "-odir"+      , output+      , "-ohi"+      , output </> "Main.hi"+      ]+  pure (App root [model, view, output </> "Main.o"])++linkApp :: App -> IO Executable+linkApp (App root objects) = do+  let path = root </> "app"+  _ <- command "ghc" (["-v0", "-o", path] ++ objects)+  pure (Executable path)++generateDocs :: Sources -> IO Documentation+generateDocs (Sources root) = do+  let output = root </> "docs"+  _ <-+    command+      "haddock"+      ( ["--html", "--hyperlinked-source", "--title=Chart demo", "--odir=" ++ output]+          ++ [root </> "src" </> name ++ ".hs" | (name, _) <- sourceFiles]+      )+  pure (Documentation output)++packageApp :: (Executable, Documentation) -> IO Package+packageApp (Executable executable, Documentation docs) = do+  let root = takeDirectory executable+      archive = root </> "app.tar.gz"+  _ <-+    command+      "tar"+      ["-czf", archive, "-C", root, "app", "-C", takeDirectory docs, takeFileName docs]+  pure (Package archive)++-- * Execution++-- Star supplies the profunctor and concurrent tensor through Concurrently's applicative.+-- Job adds sequential composition locally for isolated jobs: independent effects must commute,+-- and scheduling differences are ignored when comparing results.+type Job :: Type -> Type -> Type+newtype Job a b = Job (Star (Prelude Async.Concurrently) a b)+  deriving newtype (Profunctor, MonoidalProfunctor)++fromIO :: (a -> IO b) -> Job a b+fromIO f = Job (Star (Prelude P.. Async.Concurrently P.. f))++runJob :: Job a b -> a -> IO b+runJob (Job (Star f)) = Async.runConcurrently P.. unPrelude P.. f++instance Promonad Job where+  id = fromIO pure+  g . f = fromIO (runJob f >=> runJob g)++instance Sized (KLEISLI Job) where+  sizeOf = 2++runWith :: HG.Wiring (KLEISLI Job) -> IO Run+runWith wiring = withBuildRun \workspace record -> do+  let job :: String -> (a -> IO b) -> Kleisli (KL a :: KLEISLI Job) (KL b)+      job name action = Kleisli (loggedJob record name action)+      graph =+        buildGraph+          (job "prepare sources" prepareSources)+          (job "compile Model" (compileModule "Model"))+          (job "compile View" (compileModule "View"))+          (job "compile Main" compileMain)+          (job "link" linkApp)+          (job "generate docs" generateDocs)+          (job "package" packageApp)+  Str (Kleisli execute) <- either fail pure (HG.simplify wiring graph)+  runJob execute workspace++runSequential :: IO Run+runSequential = runWith HG.copyDiscard++runParallel :: IO Run+runParallel = runWith (HG.layered HG.copyDiscard)++-- * Demo support++data Event = Event {seconds :: Double, jobName :: String, phase :: String} deriving stock (Eq, Show)+data Run = Run {result :: String, elapsed :: Double, events :: [Event]} deriving stock (Eq, Show)++loggedJob :: (String -> String -> IO ()) -> String -> (a -> IO b) -> Job a b+loggedJob record name action = fromIO \a -> do+  record name "start"+  b <- action a+  record name "finish"+  pure b++-- Measure only the build, then verify its package and remove the temporary workspace.+withBuildRun :: (Workspace -> (String -> String -> IO ()) -> IO Package) -> IO Run+withBuildRun build = withSystemTempDirectory "proarrow-build" \root -> do+  logbook <- newMVar []+  started <- getMonotonicTimeNSec+  let sinceStart = do+        now <- getMonotonicTimeNSec+        pure (fromIntegral (now - started) / 1e9)+      record name status = do+        t <- sinceStart+        modifyMVar_ logbook (pure P.. (Event t name status :))+  package <- build (Workspace root) record+  duration <- sinceStart+  trace <- sortOn seconds <$> readMVar logbook+  value <- verifyPackage package+  pure (Run value duration trace)++verifyPackage :: Package -> IO String+verifyPackage (Package archive) = do+  let unpacked = takeDirectory archive </> "unpacked"+  createDirectory unpacked+  _ <- command "tar" ["-xzf", archive, "-C", unpacked]+  value <- command (unpacked </> "app") []+  contents <- readFile' (unpacked </> "docs" </> "index.html")+  if value == expected && "Chart demo" `isInfixOf` contents+    then pure value+    else fail "packaged application or documentation is incorrect"++-- | Build and check both schedules, saving diagrams and measured timelines in the given directory.+-- The installed GHC and host load affect timings; concurrency need not make a tiny build faster.+demo :: FilePath -> IO ()+demo directory = do+  createDirectoryIfMissing True directory+  sequential <- runSequential+  parallel <- runParallel+  display "Sequential" sequential+  display "Layered" parallel+  either fail (writeFile (directory </> "sequential.svg")) sequentialPicture+  either fail (writeFile (directory </> "parallel.svg")) parallelPicture+  writeFile (directory </> "timeline.svg") (timeline sequential parallel)+  putStrLn ("Diagrams and measured timeline: " ++ directory)+  putStrLn ("Packaged executable output:\n" ++ result parallel)+  where+    display title run = do+      putStrLn title+      mapM_ (\(Event t name status) -> printf "  %5.3fs  %-14s %s\n" t name status) (events run)+      printf "  total: %.3fs\n\n" (elapsed run)++-- | Both measured schedules on the same time scale. Job names come from this example's fixed labels.+timeline :: Run -> Run -> String+timeline sequential parallel =+  "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"+    ++ "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"900\" height=\"570\" viewBox=\"0 0 900 570\">"+    ++ "<rect width=\"900\" height=\"570\" fill=\"white\"/><g font-family=\"sans-serif\" font-size=\"14\">"+    ++ panel 28 "Sequential build" sequential+    ++ panel 300 "Automatic parallel build" parallel+    ++ "</g></svg>"+  where+    scale = 640 / max 0.001 (max (elapsed sequential) (elapsed parallel))+    names = ["prepare sources", "compile Model", "compile View", "compile Main", "link", "generate docs", "package"]+    panel :: Int -> String -> Run -> String+    panel y title run =+      printf "<text x=\"20\" y=\"%d\" font-weight=\"bold\">%s: %.3fs</text>" y title (elapsed run)+        ++ concat [bar (y + 18 + i * 28) name run | (i, name) <- zip [0 ..] names]+        ++ printf "<path d=\"M180 %d H820\" stroke=\"#aaa\"/>" (y + 228)+        ++ concat+          [ printf+              "<text x=\"%.2f\" y=\"%d\" text-anchor=\"middle\" fill=\"#555\">%.2fs</text>"+              (180 + t * scale)+              (y + 248)+              t+          | i <- [0 .. 4 :: Int]+          , let t = fromIntegral i * max (elapsed sequential) (elapsed parallel) / 4+          ]+    bar :: Int -> String -> Run -> String+    bar y name run =+      printf "<text x=\"20\" y=\"%d\">%s</text>" (y + 15) name+        ++ concat+          [ printf+              "<rect x=\"%.2f\" y=\"%d\" width=\"%.2f\" height=\"21\" rx=\"3\" fill=\"#4078b5\"/>"+              (180 + start * scale)+              y+              (max 2 ((end - start) * scale))+          | Event start job "start" <- events run+          , job == name+          , Event end job' "finish" <- events run+          , job' == name+          ]++-- * Pictures and pure checks++picture :: HG.Wiring SVG -> Either String (Svg (S '[Wire "dir"]) (S '[Wire "pkg"]))+picture wiring = do+  Str diagram <-+    HG.simplify wiring $+      buildGraph+        (node @'[Wire "dir"] @'[Wire "src"] "prepare sources")+        (node @'[Wire "src"] @'[Wire "obj"] "compile Model")+        (node @'[Wire "src"] @'[Wire "obj"] "compile View")+        (node @'[Wire "obj", Wire "obj"] @'[Wire "app"] "compile Main")+        (node @'[Wire "app"] @'[Wire "exe"] "link")+        (node @'[Wire "src"] @'[Wire "doc"] "generate docs")+        (node @'[Wire "exe", Wire "doc"] @'[Wire "pkg"] "package")+  pure diagram++sequentialPicture, parallelPicture :: Either String String+sequentialPicture = render <$> picture HG.copyDiscard+parallelPicture = render <$> picture (HG.layered HG.copyDiscard)++-- Gate groups in a composition, with tensor operands sharing a stage.+stages :: Svg.Diagram -> [[String]]+stages = \case+  Svg.Node _ title _ _ -> [[title]]+  Svg.Seq a b -> stages a ++ stages b+  Svg.Beside a b -> together (stages a) (stages b)+  Svg.Trace _ d -> stages d+  _ -> []+  where+    together [] bs = bs+    together as [] = as+    together (a : as) (b : bs) = (a ++ b) : together as bs++test :: TestTree+test =+  testGroup+    "Parallel build"+    [ testProperty "sequential job dependencies" $+        case picture HG.copyDiscard of+          Left err -> testFailed err+          Right (Svg _ diagram) ->+            expect+              "stages"+              [["prepare sources"], ["compile Model"], ["compile View"], ["compile Main"], ["link"], ["generate docs"], ["package"]]+              (map sort (stages diagram))+    , testProperty "layered jobs respect dependencies" $+        case picture (HG.layered HG.copyDiscard) of+          Left err -> testFailed err+          Right (Svg _ diagram) ->+            expect+              "stages"+              [["prepare sources"], ["compile Model", "compile View", "generate docs"], ["compile Main"], ["link"], ["package"]]+              (map sort (stages diagram))+    ]
+ test/Examples/Probabilistic.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE QualifiedDo #-}++-- | Discrete probabilistic programs as string diagrams, after Peterseim and Lopuhaä-Zwakenberg,+-- /Fixed-Parameter Tractable Inference for Discrete Probabilistic Programs, via String Diagram+-- Algebraisation/ (LICS 2026). A program is a term over Boolean wires built from biased coins,+-- the connectives and @observe@, which keeps the runs in which a wire is true.+--+-- * In tensor networks a Boolean is a wire of dimension 2, a coin is the vector of its two+--   probabilities, the connectives are 0-1 matrices, and @observe@ picks out the entry for true.+--   Discarding a wire sums it out and copying a wire copies its value, so the program computes the+--   probability of each result together with the observations holding: running it is inference.+-- * Run as one network instead, with every building block a tensor on all its wires, the+--   read-back of open hypergraphs contracts the whole program in a planned order, as the paper's+--   algebraisation does, and gives the same probabilities.+-- * In string diagrams the same program is drawn, with a box for each coin and connective.+-- * Functions that call functions are evaluated once each and then combined, so a family of+--   programs whose probability of true is @2^-2^(n+1)@ costs linear time in @n@.+module Examples.Probabilistic (test, diseasePicture) where++import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Vector.Storable qualified as SV+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (id, (**), (.))++import Proarrow.Category.Instance.OpenHypergraph (SIMPLIFY, Wires, prim, prim0, prim1, prim2, simplifyFlat)+import Proarrow.Category.Instance.TensorNetwork (TNET (..), fromEntries, toVector)+import Proarrow.Category.Monoidal (Monoidal (..))+import Proarrow.Category.Monoidal.CopyDiscard (CopyDiscard)+import Proarrow.Category.Monoidal.Strictified (Strictified (..))+import Proarrow.Core (CategoryOf (..), Promonad (..))+import Proarrow.Testing (check)+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.SMC (SYN (..), Term, toSMC, toSMC1, unit, (*^), (-<))+import Proarrow.Tools.SMC qualified as SMC++-- * Programs++-- | The building blocks of programs over Booleans @b@: a coin that is true with the given+-- probability, the connectives, and @observe@.+type Prims :: forall {k}. k -> Type+data Prims b = Prims+  { flipP :: Double -> Unit ~> b+  , andP :: b ** b ~> b+  , orP :: b ** b ~> b+  , notP :: b ~> b+  , observeP :: b ~> Unit+  }++-- | The connectives as terms.+andT+  , orT+    :: forall {k} (b :: k) d g1 g2+     . (Monoidal k, Ob b, SMC.Merge g1 g2)+    => Prims b -> Term d g1 (F b) -> Term d g2 (F b) -> Term d (SMC.Union g1 g2) (F b)+andT p x y = andP p -< (x, y)+orT p x y = orP p -< (x, y)++notT :: forall {k} (b :: k) d g. (Monoidal k, Ob b) => Prims b -> Term d g (F b) -> Term d g (F b)+notT p x = notP p -< x++-- | A program without inputs as a term: a call of it.+call :: forall {k} (b :: k) d. (Monoidal k, Ob b) => (Unit ~> b) -> Term d '[] (F b)+call f = f -< unit++-- | A coin that is true with the given probability.+coin :: (Monoidal k, Ob (b :: k)) => Prims b -> Double -> Term d '[] (F b)+coin p q = call (flipP p q)++-- | The test of the paper's running example on a patient: positive with probability 0.99 when the+-- patient has the disease, and with probability 0.02 when not. Each call flips its own coins.+diseaseTest :: forall {k} (b :: k). (CopyDiscard k, Ob b) => Prims b -> b ~> b+diseaseTest p = toSMC1 \z -> orT p (andT p z (coin p 0.99)) (andT p (notT p z) (coin p 0.02))++-- | Whether a patient has the disease, which one in ten thousand have, given one positive and one+-- negative test.+hasDisease :: forall {k} (b :: k). (CopyDiscard k, Ob b) => Prims b -> Unit ~> b+hasDisease p = toSMC @I @(F b) \() -> SMC.do+  x <- coin p 1e-4+  let t y = diseaseTest p -< y+  (observeP p -< andT p (t x) (notT p (t x))) *^ x++-- | A family of programs: @f 0@ is the conjunction of two fair coins, and @f (n + 1)@ the+-- conjunction of two calls of @f n@, so it is true with probability @2^-2^(n+1)@. Each @f n@ is a+-- function of its own, compiled once and called twice.+family :: forall {k} (b :: k). (CopyDiscard k, Ob b) => Prims b -> Int -> Unit ~> b+family p 0 = toSMC @I @(F b) \() -> andT p (coin p 0.5) (coin p 0.5)+family p n = let f = family p (n - 1) in toSMC @I @(F b) \() -> andT p (call f) (call f)++-- * Inference++-- | A Boolean as a wire of dimension 2: false, then true.+type Bit :: TNET Double+type Bit = TN '[2]++-- | The building blocks as tensor networks.+tensors :: Prims Bit+tensors =+  Prims+    { flipP = \q -> fromEntries [[1 - q], [q]]+    , andP = fromEntries [[1, 1, 1, 0], [0, 0, 0, 1]]+    , orP = fromEntries [[1, 0, 0, 0], [0, 1, 1, 1]]+    , notP = fromEntries [[0, 1], [1, 0]]+    , observeP = fromEntries [[0, 1]]+    }++-- | The building blocks as boxes of open hypergraphs, to run a whole program as one network.+boxedTensors :: Prims (Wires '[Bit] :: SIMPLIFY (TNET Double))+boxedTensors =+  Prims+    { flipP = \q -> prim0 (flipP tensors q)+    , andP = prim2 (andP tensors)+    , orP = prim2 (orP tensors)+    , notP = prim1 (notP tensors)+    , observeP = prim (Str (observeP tensors))+    }++-- | A program run as one network of tensors, each box bent into a state on all its wires, and+-- contracted in the order of 'Proarrow.Tools.ContractionOrder.planContraction', as the paper's+-- algebraisation does.+asNetwork :: (Unit ~> (Wires '[Bit] :: SIMPLIFY (TNET Double))) -> Unit ~> Bit+asNetwork f = unStr (simplifyFlat f)++-- | The probability of each result of a program together with its observations holding.+probabilities :: (Unit ~> Bit) -> (Double, Double)+probabilities f = let v = toVector f in (v SV.! 0, v SV.! 1)++-- * Pictures++-- | A Boolean as a wire of a string diagram.+type SB = S '[Wire "𝔹"]++-- | The building blocks as boxes.+boxes :: Prims SB+boxes =+  Prims+    { flipP = node . show+    , andP = node "∧"+    , orP = node "∨"+    , notP = node "¬"+    , observeP = node "observe"+    }++-- | The running example, drawn.+diseasePicture :: String+diseasePicture = render (hasDisease boxes)++test :: TestTree+test =+  testGroup+    "Probabilistic programs"+    [ testProperty "inference gives the probability of each answer together with the observations" do+        let (healthy, ill) = probabilities (hasDisease tensors)+            prior = 1e-4+            expectedIll = prior * 0.99 * 0.01+            expectedHealthy = (1 - prior) * 0.02 * 0.98+        check ("found " ++ show (healthy, ill)) (abs (ill - expectedIll) < 1e-15 && abs (healthy - expectedHealthy) < 1e-15)+    , testProperty "run as one network of tensors, contracted in a planned order, it gives the same" do+        let (healthy, ill) = probabilities (hasDisease tensors)+            (healthy', ill') = probabilities (asNetwork (hasDisease boxedTensors))+        check ("found " ++ show (healthy', ill')) (abs (healthy - healthy') < 1e-15 && abs (ill - ill') < 1e-15)+    , testProperty "the nested family is true with doubly exponentially small probability" do+        let (_, true5) = probabilities (family tensors 5)+            (_, true1000) = probabilities (family tensors 1000)+        check ("found " ++ show true5) (true5 == 2 ^^ (-64 :: Int))+        -- each member is evaluated once, so even the thousandth is quick; its probability underflows+        check ("found " ++ show true1000) (true1000 == 0)+    , testProperty "the running example draws" do+        check "not an SVG document" ("<svg" `isInfixOf` diseasePicture)+    ]
test/Examples/Sessions.hs view
@@ -41,6 +41,7 @@   , toSMC   , unit   , (**)+  , (-<)   , (|>)   , type (:##)   )@@ -202,13 +203,13 @@  -- | A message, from nothing. put :: forall a d. a -> SMC.Term d '[] (F (L (Ur a)))-put x = lift @I @(F (L (Ur a))) (Linear \() -> Ur x) unit+put x = (Linear \() -> Ur x) -< unit  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))+compute p = (Linear \(Ur n, Ur c) -> Ur (n ++ ", paid with " ++ show c)) -< p  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))+lookupPrice x = (Linear \(Ur n) -> Ur (length n)) -< x  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)"))+annotate x = (Linear \(Ur s) -> Ur (s ++ " (via broker)")) -< x
+ test/Examples/Squares.hs view
@@ -0,0 +1,199 @@+-- | Update the value field of every named entry, using square optics. 'field' is a lens,+-- 'each' is a list traversal, and 'fused' combines their witnesses into one absorption.+module Examples.Squares where++import Data.Kind (Type)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core ((:~>), type (+->))+import Proarrow.Functor qualified as F+import Proarrow.Limit.BinaryProduct (Product)+import Proarrow.Object (pattern Objs)+import Proarrow.Optic (Prostrong)+import Proarrow.Optic.Traversal (TravFl)+import Proarrow.Path (Path (..))+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Representable (Rep (..), RepCostar (..), Representable (..))+import Proarrow.Squares+import Proarrow.Testing (expect, genNamed)+import Props.Hask ()++-- * Data and effects++data Entry a = Entry {entryName :: String, entryValue :: a}+  deriving (Eq, Show)++-- | The list records the old ages, in the order their effects execute.+data Logged a = Logged {visits :: [Int], result :: a}+  deriving (Eq, Show, Functor)++instance Applicative Logged where+  pure = Logged []+  Logged xs f <*> Logged ys x = Logged (xs ++ ys) (f x)++type Effect :: Type +-> Type+type Effect = Star (F.Prelude Logged)++type Point :: Type -> () +-> Type+type Point a = Rep (Constant a)++type Cell :: (Type +-> Type) -> Type -> Type -> Type+type Cell r a b = InputSquare r (Point a) (Point b)++-- | Introduce a primitive effect as a square; 'runCell' is the execution boundary.+primitive :: (a -> Logged b) -> Cell Effect a b+primitive f = mkSquare (\(Id Unit) -> Star (F.Prelude . f))++runCell :: Cell Effect a b -> a -> Logged b+runCell sq = F.unPrelude . unStar (runSquare sq (Id Unit))++-- * The value-field lens++type FieldP :: Type +-> Type+type FieldP = Rep (Product String)+type FieldQ :: Type +-> Type+type FieldQ = Corep (Product String)++fieldUnpackNat :: Point (Entry a) :~> FieldP :.: Point a+fieldUnpackNat (Rep f) = Rep (\x -> let Entry name a = f x in (name, a)) :.: Rep id++fieldRebuildNat :: Point b :~> FieldQ :.: Point (Entry b)+fieldRebuildNat (Rep g) = Corep id :.: Rep (\(name, b) -> Entry name (g b))++fieldUnpack :: Cell FieldP (Entry a) a+fieldUnpack = Sq fieldUnpackNat++fieldRebuild :: Cell FieldQ b (Entry b)+fieldRebuild = Sq fieldRebuildNat++-- | Focus an entry's value while carrying its name as the residual. In the diagram,+-- @s@/@t@ are the entry shapes, @a@/@b@ the value shapes, @p = FieldP@, and+-- @q = FieldQ@. The legs introduce residual effects, which are absorbed below the input.+-- Wire names stay on borders; each contiguous run of @\@@ is one transformation.+--+-- > +-----+-----+-----++-- > |     |     |     |+-- > s>-@->a>-@->b>-@->t+-- > |  |  |  |  |  |  |+-- > +--p--+--r--+--q--++-- > |   \    |    /   |+-- > |    @@@@@@@@@    |+-- > |        |        |+-- > +--------r--------++field :: forall r a b. (Prostrong TravFl r) => Cell r a b -> Cell r (Entry a) (Entry b)+field input =+  fieldUnpack ||| input ||| fieldRebuild+    === proSquare @TravFl @r @FieldP @FieldQ++-- * Traverse a list of entries++type ListP :: Type +-> Type+type ListP = Star []+type ListQ :: Type +-> Type+type ListQ = RepCostar ListP++listUnpackNat :: Point [a] :~> ListP :.: Point a+listUnpackNat f@Objs = tabulate (index f)++listRebuildNat :: Point b :~> ListQ :.: Point [b]+listRebuildNat (Rep g) = RepCostar id :.: Rep (map g)++listUnpack :: Cell ListP [a] a+listUnpack = Sq listUnpackNat++listRebuild :: Cell ListQ b [b]+listRebuild = Sq listRebuildNat++-- | Visit every element, in list order. Its diagram is the same as 'field', with+-- @p = ListP@ and @q = ListQ@. Feeding the output of 'field' into 'each'+-- makes the complete entry update the input square of the list traversal.+each :: forall r a b. (Prostrong TravFl r) => Cell r a b -> Cell r [a] [b]+each input =+  listUnpack ||| input ||| listRebuild+    === proSquare @TravFl @r @ListP @ListQ++-- | A lens inside a traversal, composed by feeding one square program into the other.+entries :: (Prostrong TravFl r) => Cell r a b -> Cell r [Entry a] [Entry b]+entries input = each (field input)++-- * Fuse the two absorptions++type BothP :: Type +-> Type+type BothP = ListP :.: FieldP+type BothQ :: Type +-> Type+type BothQ = FieldQ :.: ListQ++-- | Compose the unpacking squares horizontally, then combine their residual effects.+unpackBoth :: Cell BothP [Entry a] a+unpackBoth =+  listUnpack ||| fieldUnpack+    === vCombineAll @(FieldP ::: ListP ::: Nil)++-- | Rebuilding composes in the other order: the field square precedes the list square.+rebuildBoth :: Cell BothQ b [Entry b]+rebuildBoth =+  fieldRebuild ||| listRebuild+    === vCombineAll @(ListQ ::: FieldQ ::: Nil)++-- | The same update with one absorption for the composed witness pair:+-- @p = ListP :.: FieldP@ and @q = FieldQ :.: ListQ@. Their effects remain vertical+-- or diagonal, including when the witnesses happen to be representable/corepresentable.+-- 'unpackBoth' and 'rebuildBoth' compose the surrounding legs with squares as well.+-- Agreement with 'entries' is the composition law for 'Prostrong'.+--+-- > +--p--r--q--++-- > |   \ | /   |+-- > |    @@@    |+-- > |     |     |+-- > +-----r-----++fused :: forall r a b. (Prostrong TravFl r) => Cell r a b -> Cell r [Entry a] [Entry b]+fused input =+  unpackBoth ||| input ||| rebuildBoth+    === proSquare @TravFl @r @BothP @BothQ++-- * Execute the square program++increment :: Int -> Logged Int+increment age = Logged [age] (age + 1)++-- | Increment both ages, preserving the names and recording the visits as @[36,85]@.+demo :: Logged [Entry Int]+demo = runCell (entries (primitive increment)) [Entry "Ada" 36, Entry "Grace" 85]++test :: TestTree+test =+  testGroup+    "Square programs"+    [ testProperty "field lens preserves the name and visits its value once" $+        expect "field" (Logged [36] (Entry "Ada" 37)) (runCell (field (primitive increment)) (Entry "Ada" 36))+    , testProperty "lens and traversal update each field in list order" $ do+        flags <- genNamed @[Bool] "ages"+        let rows = sampleRows flags+            Logged seen updated = runCell (entries (primitive increment)) rows+        expect "effect order" (map entryValue rows) seen+        expect "names and values" (map (\(Entry name age) -> Entry name (age + 1)) rows) updated+    , testProperty "composed witnesses agree with sequential square optics" $ do+        flags <- genNamed @[Bool] "ages"+        let rows = sampleRows flags+            input = primitive increment+        expect "composition" (runCell (entries input) rows) (runCell (fused input) rows)+    , testProperty "composition also preserves type-changing updates" $ do+        flags <- genNamed @[Bool] "ages"+        let rows = sampleRows flags+            input = primitive (\age -> Logged [age] (show age))+            expected = Logged (map entryValue rows) (map (\(Entry name age) -> Entry name (show age)) rows)+        expect "sequential" expected (runCell (entries input) rows)+        expect "composed" expected (runCell (fused input) rows)+    , testProperty "empty traversal runs no effects" $+        expect "empty" (Logged [] []) (runCell (fused (primitive increment)) [])+    ]++sampleRows :: [Bool] -> [Entry Int]+sampleRows = zipWith (\n b -> Entry (show n) (if b then 7 else 0)) [0 :: Int ..]
test/Examples/Toffoli.hs view
@@ -39,7 +39,7 @@ import Proarrow.Monoid (Comonoid (..)) import Proarrow.Testing (check) import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)-import Proarrow.Tools.SMC (Merge, SYN (..), Term, Union, lift, toSMC, (**))+import Proarrow.Tools.SMC (Merge, SYN (..), Term, Union, toSMC, (**), (-<)) import Proarrow.Tools.SMC qualified as SMC  -- * The circuit@@ -54,21 +54,17 @@   }  toffoliWith :: forall {k} (q :: k). (SymMonoidal k, Ob q) => Gates q -> q ** q ** q ~> q ** q ** q-toffoliWith gates = toSMC @(F q :** F q :** F q) \(a0, b0, x0) -> SMC.do-  (a1, x1) <- cnot a0 (h x0)-  (b1, x2) <- cnot b0 (t' x1)-  (a2, x3) <- cnot a1 (t x2)-  (b2, x4) <- cnot b1 (t' x3)-  (b3, a3) <- cnot b2 (t a2)-  (b4, a4) <- cnot (t b3) (t' a3)-  a4 ** b4 ** h (t x4)+toffoliWith (Gates h t t' controlledNot) = toSMC @(F q :** F q :** F q) @(F q :** F q :** F q) \(a0, b0, x0) -> SMC.do+  (a1, x1) <- cnot a0 (h -< x0)+  (b1, x2) <- cnot b0 (t' -< x1)+  (a2, x3) <- cnot a1 (t -< x2)+  (b2, x4) <- cnot b1 (t' -< x3)+  (b3, a3) <- cnot b2 (t -< a2)+  (b4, a4) <- cnot (t -< b3) (t' -< a3)+  a4 ** b4 ** (h -< t -< x4)   where-    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) -> Term d g2 (F q) -> Term d (Union g1 g2) (F q :** F q)-    cnot c x = lift (cnotG gates) (c ** x)+    cnot :: (Merge g1 g2) => Term d g1 (F q) -> Term d g2 (F q) -> Term d (Union g1 g2) (F (q ** q))+    cnot c x = controlledNot -< (c, x)  -- | The same circuit written directly with the monoidal structure, for comparison. The wires are -- @a ** b ** x@, and each two-qubit gate needs its two wires moved next to each other by hand.
test/Main.hs view
@@ -5,24 +5,35 @@ import Test.Tasty (defaultMain, testGroup) import Prelude +import Examples.CCC qualified as CCC import Examples.Cbpv qualified as Cbpv+import Examples.Circuit qualified as Circuit import Examples.CustomLaws qualified as CustomLaws import Examples.Database qualified as Database import Examples.Einsum qualified as Einsum+import Examples.FRP qualified as FRP import Examples.Free qualified as FreeExample import Examples.Graph qualified as Graph import Examples.IntComposition qualified as IntComposition+import Examples.Learning qualified as Learning import Examples.LinearLogic qualified as LinearLogic+import Examples.OpticDiagrams qualified as OpticDiagrams+import Examples.Parallel qualified as Parallel+import Examples.Probabilistic qualified as Probabilistic import Examples.Sessions qualified as Sessions import Examples.SimplyTypedLambdaCalculus qualified as STLC+import Examples.Squares qualified as SquarePrograms import Examples.Toffoli qualified as Toffoli import Examples.UntypedLambdaCalculus qualified as ULC import Examples.Vitrea qualified as Vitrea import Props.Bool qualified as Bool+import Props.Circuit qualified as CircuitLaws+import Props.ContractionOrder qualified as ContractionOrder import Props.Cospan qualified as Cospan import Props.Cost qualified as Cost import Props.Cps qualified as Cps import Props.DPO qualified as DPO+import Props.Diff qualified as Diff import Props.Discrete qualified as Discrete import Props.Dot qualified as Dot import Props.FinHask qualified as FinHask@@ -47,7 +58,9 @@ import Props.Sheaf.Chain qualified as SheafChain import Props.Sheaf.Collage qualified as SheafCollage import Props.Simplex qualified as Simplex+import Props.Simulator qualified as Simulator import Props.Span qualified as Span+import Props.Squares qualified as Squares import Props.Svg qualified as Svg import Props.TensorNetwork qualified as TensorNetwork import Props.ZX qualified as ZX@@ -60,6 +73,7 @@       [ testGroup           "Proarrow"           [ Bool.test+          , CircuitLaws.test           , Discrete.test           , Cospan.test           , OpenHypergraph.test@@ -87,25 +101,37 @@           , SheafChain.test           , SheafCollage.test           , Simplex.test+          , Simulator.test           , SMC.test+          , Squares.test           , Span.test           , Svg.test           , TensorNetwork.test+          , ContractionOrder.test+          , Diff.test           , ZX.test           ]       , testGroup           "Examples"           [ CustomLaws.test+          , CCC.test           , Database.test           , Einsum.test+          , FRP.test           , FreeExample.test           , Graph.test           , STLC.test           , ULC.test           , IntComposition.test           , LinearLogic.test+          , Learning.test+          , Probabilistic.test+          , OpticDiagrams.test+          , Parallel.test           , Sessions.test+          , SquarePrograms.test           , Cbpv.test+          , Circuit.test           , Toffoli.test           , Vitrea.test           ]
+ test/Props/Circuit.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Circuit (test) where++import Data.Kind (Constraint)+import Test.Tasty (TestTree, testGroup)+import Prelude hiding (fmap, id, (**), (.))++import Proarrow.Category.Instance.Circuit+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), Tensor)+import Proarrow.Category.Monoidal.Strength (Costrong (..))+import Proarrow.Core (Is, Promonad (..), UN, obj)+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Monoid (Comonoid (..))+import Proarrow.Profunctor.Representable (Rep)+import Proarrow.Testing+  ( GenTotal+  , Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genNamed+  , genSomeDef+  , oneOfTotal+  , optGen+  )+import Proarrow.Testing.Laws+  ( testCategory+  , testCopyDiscard+  , testMonoidal+  , testMonoidalProfunctor+  , testProfunctor+  , testRepresentable+  , testSymMonoidal+  , testTraced+  )+import Props.Hask ()+import Props.Simulator ()++test :: TestTree+test =+  testGroup+    "Circuit"+    [ testCategory @Wires+    , testMonoidal @Wires (\r -> r)+    , testSymMonoidal @Wires (\r -> r)+    , testCopyDiscard @Wires (\r -> r)+    , testTraced @Wires (\r -> r)+    , testGroup+        "Prepared"+        [ testCategory @PREPARED+        , testMonoidal @PREPARED (\r -> r)+        , testSymMonoidal @PREPARED (\r -> r)+        , testCopyDiscard @PREPARED (\r -> r)+        ]+    , testGroup+        "Value"+        [ testProfunctor @(Rep Value)+        , testRepresentable @(Rep Value) (\r -> r)+        , testMonoidalProfunctor @(Rep Value) (\r -> r) (\r -> r)+        ]+    ]++-- Generate circuits through the public API, preserving the grouping of their boundaries.+type TestWires :: Wires -> Constraint+class (KnownWires a, TestOb (Sample a)) => TestWires a where+  wireName :: String+  projections :: [Circuit a Bit]+  assemble :: (KnownWires b) => GenTotal (Circuit b Bit) -> GenTotal (Circuit b a)+instance TestWires Bit where+  wireName = "Bit"+  projections = [id]+  assemble = id+instance TestWires Empty where+  wireName = "Empty"+  projections = []+  assemble _ = pure counit+instance (TestWires a, TestWires b) => TestWires (Pair a b) where+  wireName = "(" ++ wireName @a ++ " ** " ++ wireName @b ++ ")"+  projections =+    map (. (rightUnitor . (obj @a ** counit @b))) (projections @a)+      ++ map (. (leftUnitor . (counit @a ** obj @b))) (projections @b)+  assemble bit = (\f g -> (f ** g) . comult) <$> assemble @a bit <*> assemble @b bit++instance Testable Wires where+  type TestOb a = TestWires a+  obFromTestOb r = r+  showOb @a = wireName @a+  genSome = genSomeDef @'[Empty, Bit, Pair Bit Bit]++genBit :: forall a. (TestWires a) => Int -> GenTotal (Circuit a Bit)+genBit depth = oneOfTotal (leaves ++ gates)+  where+    leaves = ((\b -> constant b . counit) <$> gen @Bool) : map pure (projections @a)+    child = genBit @a (depth - 1)+    gates+      | depth <= 0 = []+      | otherwise =+          [ (notGate .) <$> child+          , (\gate f g -> gate . (f ** g) . comult) <$> optGen [andGate, orGate, xorGate] <*> child <*> child+          , (\s f g -> mux . ((s ** f) ** g) . (comult ** id) . comult) <$> child <*> child <*> child+          , (\initial f -> register initial . f) <$> gen @Bool <*> child+          , (\initial f -> coact @Tensor @Circuit @Bit (comult . register initial . xorGate . (obj @Bit ** f)))+              <$> gen @Bool+              <*> child+          ]++instance (TestWires a, TestWires b) => TestableType (Circuit a b) where+  gen = assemble @b (genBit @a 2)++instance (TestWires a, TestWires b) => TestingEqShow (Circuit a b) where+  showP = renderNetlist . netlist+  eqP f g = do+    xs <- genNamed @[Sample a] "clock inputs"+    -- Trace laws can create unguarded cycles. Compare their rejection status rather than local+    -- wire numbers; executable circuits are compared by their outputs over the sampled clocks.+    case (simulate f xs, simulate g xs) of+      (Right ys, Right zs) -> eqP ys zs+      (Left _, Left _) -> pure True+      _ -> pure False++instance TestableProfunctor Circuit++instance Testable PREPARED where+  type TestOb a = (Is Ready a, TestWires (UN Ready a))+  obFromTestOb r = r+  showOb @(Ready a) = "Ready " ++ wireName @a+  genSome = genSomeDef @'[Ready Empty, Ready Bit, Ready (Pair Bit Bit)]++instance (TestWires a, TestWires b) => TestableType (Prepared (Ready a) (Ready b)) where+  -- Generated circuits contain only guarded feedback; rejection is a generator bug.+  gen = either (error . show) id . prepare . netlist <$> gen @(Circuit a b)++instance (TestWires a, TestWires b) => TestingEqShow (Prepared (Ready a) (Ready b)) where+  showP = showP . fmap @Value+  eqP f g = eqP (fmap @Value f) (fmap @Value g)++instance TestableProfunctor Prepared+instance TestableProfunctor (Rep Value)
+ test/Props/ContractionOrder.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedLists #-}++-- | Contraction plans: each factor is used once, each contraction joins two parts that share a node+-- that may be contracted, and no two results share such a node.+module Props.ContractionOrder (test) where++import Control.Monad (replicateM)+import Data.List (sort)+import Data.Set (Set)+import Data.Set qualified as Set+import Test.Falsify (Property)+import Test.Falsify qualified as F+import Test.Falsify.Generator (elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (elem)++import Proarrow.Testing (check)+import Proarrow.Tools.ContractionOrder (Plan (..), planContraction)++-- | Factors on up to eight nodes, the nodes needed outside, and which nodes may be contracted.+network :: Property ([Set Int], Set Int, Int -> Bool)+network = do+  k <- F.gen (elem [1 .. 8])+  factors <- replicateM k do+    arity <- F.gen (elem [1 .. 3])+    Set.fromList <$> replicateM arity (F.gen (elem [0 .. 7]))+  needed <- Set.fromList <$> replicateM 2 (F.gen (elem [0 .. 7]))+  cut <- F.gen (elem [0 .. 8])+  pure (factors, needed, (< cut))++-- | The factors of a plan.+factorsOf :: Plan -> [Int]+factorsOf (Factor i) = [i]+factorsOf (Contract a b) = factorsOf a ++ factorsOf b++-- | The plans for a network, with the nodes something outside each part needs.+planned :: ([Set Int], Set Int, Int -> Bool) -> ([Plan], Plan -> Set Int)+planned (factors, needed, contractible) = (planContraction (fromIntegral . Set.size) contractible needed factors, open)+  where+    open p =+      let inside = factorsOf p+          nodes = Set.unions [factors !! i | i <- inside]+          outside = Set.unions [f | (i, f) <- zip [0 ..] factors, i `notElem` inside]+      in Set.filter (\n -> n `Set.member` needed || n `Set.member` outside) nodes++test :: TestTree+test =+  testGroup+    "Contraction order"+    [ testProperty "each factor is used once" do+        net@(factors, _, _) <- network+        let (ps, _) = planned net+        check ("plans " ++ show ps) (sort (concatMap factorsOf ps) == [0 .. length factors - 1])+    , testProperty "each contraction joins two parts that share a node that may be contracted" do+        net@(_, _, contractible) <- network+        let (ps, open) = planned net+            joins (Factor _) = True+            joins (Contract a b) = any contractible (Set.intersection (open a) (open b)) && joins a && joins b+        check ("plans " ++ show ps) (all joins ps)+    , testProperty "no two results share a node that may be contracted" do+        net@(_, _, contractible) <- network+        let (ps, open) = planned net+        check+          ("plans " ++ show ps)+          ( and+              [ not (any contractible (Set.intersection (open p) (open q)))+              | (i, p) <- zip [0 :: Int ..] ps+              , (j, q) <- zip [0 ..] ps+              , i < j+              ]+          )+    ]
test/Props/Cospan.hs view
@@ -41,6 +41,7 @@     , testCompactClosed_ @(COSPAN FINSET)     , testCopyDiscard_ @(COSPAN FINSET)     , testHypergraph_ @(COSPAN FINSET)+    , testTraced_ @(COSPAN FINSET)     ]  -- instance (Testable k, HasPushouts k, TestObIsOb k) => Testable (COSPAN k) where
+ test/Props/Diff.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Differentiable maps, compared at random points: arbitrary arrows are dense layers with a+-- @tanh@, and every reverse derivative is checked against finite differences.+module Props.Diff (test) where++import Control.Monad (replicateM)+import Data.Vector.Storable qualified as SV+import GHC.TypeNats (KnownNat)+import Test.Falsify (Property)+import Test.Falsify qualified as F+import Test.Falsify.Generator (Gen, elem)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (elem, fmap, id, mappend, (**), (.))++import Examples.Learning (scores)+import Proarrow.Category.Instance.Diff+  ( AsLens+  , DIFF (..)+  , Diff (..)+  , Forget+  , Point (..)+  , add+  , backward+  , bilinear+  , broadcast+  , coordinates+  , dot+  , forward+  , fromCoordinates+  , linear+  , matMat+  , pointwise+  , scale+  , softmax+  , softmaxCrossEntropy+  , split+  , times+  , pattern Vector+  )+import Proarrow.Category.Instance.Opposite (Op (..))+import Proarrow.Category.Instance.TensorNetwork (TNET (..), dimsOf, fromVector, matMul)+import Proarrow.Category.Monoidal (MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.CopyDiscard (copy)+import Proarrow.Category.Monoidal.Hypergraph (cap)+import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), UN, obj)+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Monoid (Monoid (..))+import Proarrow.Object (KnownListOf)+import Proarrow.Optic.Lens (withLens)+import Proarrow.Profunctor.Representable (Rep)+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , check+  , genNamed+  , genP+  , genSomeDef+  , testEq+  , pattern GenNonEmpty+  )+import Proarrow.Testing.Laws+import Props.Hask ()++type R2 :: DIFF+type R2 = DF '[2]++type R3 :: DIFF+type R3 = DF '[3]++test :: TestTree+test =+  testGroup+    "Differentiable maps"+    [ testCategory @DIFF+    , testMonoidal_ @DIFF+    , testSymMonoidal_ @DIFF+    , testTerminalObject @DIFF+    , testBinaryProducts_ @DIFF+    , testCopyDiscard_ @DIFF+    , testCartesian_ @DIFF+    , testCommutativeMonoid_ @(DF '[2, 1])+    , testGroup+        "reverse derivatives are the transposed derivatives"+        [ testProperty "dense layers" (finiteDifferences @R2 @R3 =<< genNamed "f")+        , testProperty "composites" do+            f <- genNamed @(R2 ~> R3) "f"+            g <- genNamed @(R3 ~> R2) "g"+            finiteDifferences (g . f)+        , testProperty "linear maps" (finiteDifferences . linear =<< matrix @2 @3)+        , testProperty "tanh" (finiteDifferences (pointwise @3 tanh (\x -> 1 - tanh x ^ (2 :: Int))))+        , testProperty "times" (finiteDifferences (times @3))+        , testProperty "matrix times matrix" (finiteDifferences (matMat @2 @3 @4))+        , testProperty "matrix times matrix, large enough for BLAS" (finiteDifferences (matMat @16 @16 @16))+        , testProperty "broadcast" (finiteDifferences (broadcast @3 @4))+        , testProperty "softmax" (finiteDifferences (softmax @3 @2))+        , testProperty "softmax and cross-entropy" (finiteDifferences (softmaxCrossEntropy @3 @2))+        , testProperty "dot" (finiteDifferences (dot @3))+        , testProperty+            "a bilinear map, ik,jk->ij"+            (finiteDifferences (bilinear @'[2, 4] @'[3, 4] (scores @(TN '[2]) @(TN '[3]) @(TN '[4]))))+        , testProperty "copying adds the changes" do+            x <- genP @(Point '[3])+            dx <- genP @(Point '[3, 3])+            check "differs" (close (backward (copy @DIFF @R3) x dx) (forward (mappend @R3) dx))+        ]+    , testProperty "softmax gives each row probabilities that sum to 1" do+        z <- genP @(Point '[6])+        let p = coordinates (forward (softmax @3 @2) z)+        check+          ("gave " ++ show (SV.toList p))+          (SV.all (> 0) p && and [abs (SV.sum (SV.slice (3 * j) 3 p) - 1) < 1e-9 | j <- [0, 1]])+    , testProperty "the bilinear map of ik,jk->ij is a matrix times a transposed matrix" do+        p <- genP @(Point '[8, 12])+        let (Vector x, Vector y) = split @'[8] @'[12] p+        check+          "differs"+          ( close+              (forward (bilinear @'[2, 4] @'[3, 4] (scores @(TN '[2]) @(TN '[3]) @(TN '[4]))) p)+              (Vector (matMul False True 2 3 4 x y))+          )+    , testProperty "times is bilinear with the merging spider" do+        testEq "times" "times" (times @3) "bilinear mappend" (bilinear @'[3] @'[3] (mappend @(TN '[3])))+    , testProperty "matMat is bilinear with the cap on the summed index" do+        testEq+          "matMat"+          "matMat"+          (matMat @2 @3 @4)+          "bilinear (id ** cap ** id)"+          (bilinear @'[2, 3] @'[3, 4] ((obj @(TN '[2]) ** cap @(TN '[3])) ** obj @(TN '[4])))+    , testProfunctor @(Rep Forget)+    , testGroup+        "AsLens is a functor"+        [ testProperty "identity" do+            x <- genP @(Point '[2])+            dx <- genP @(Point '[2])+            check "differs" (sameLens (fmap @AsLens (id @_ @R2)) id x dx)+        , testProperty "composition, the chain rule" do+            f <- genNamed @(R2 ~> R3) "f"+            g <- genNamed @(R3 ~> R2) "g"+            x <- genP @(Point '[2])+            dz <- genP @(Point '[2])+            check "differs" (sameLens (fmap @AsLens (g . f)) (fmap @AsLens g . fmap @AsLens f) x dz)+        ]+    ]++-- | Two arrows of lenses agree on the view of a point and on the update of it with a change.+sameLens+  :: AsLens @ DF as ~> AsLens @ DF bs -> AsLens @ DF as ~> AsLens @ DF bs -> Point as -> Point bs -> Bool+sameLens (Op l) (Op l') x d = withLens l \get put -> withLens l' \get' put' ->+  close (get x) (get' x) && close (put (x, d)) (put' (x, d))++-- | A random linear map, as a tensor network.+matrix :: forall n m. (KnownNat n, KnownNat m) => Property ((TN '[n] :: TNET Double) ~> TN '[m])+matrix = fromVector . SV.fromList <$> F.gen (replicateM (product (dimsOf @'[n, m])) value)++-- | The reverse derivative at a random point, against the derivative from central differences: the+-- change of the input it gives, paired with a direction, is the change of the output along that+-- direction paired with the change of the output it was given.+finiteDifferences :: (a :: DIFF) ~> b -> Property ()+finiteDifferences f@Diff{} = do+  x <- genP+  v <- genP+  dy <- genP+  let h = 1e-5+      along s = forward f (add x (scale s v))+      derivative = scale (1 / (2 * h)) (add (along h) (scale (-1) (along (-h))))+  check "differs from finite differences" (abs (inner (backward f x dy) v - inner dy derivative) < 1e-6)++inner :: Point ns -> Point ns -> Double+inner x y = SV.sum (SV.zipWith (*) (coordinates x) (coordinates y))++-- | Whether two points are the same up to rounding.+close :: Point ns -> Point ns -> Bool+close p q = SV.length x == SV.length y && SV.and (SV.zipWith near x y)+  where+    (x, y) = (coordinates p, coordinates q)+    near a b = abs (a - b) <= 1e-9 * (1 + abs a + abs b)++-- | A small number, a multiple of a quarter.+value :: Gen Double+value = (/ 4) . fromIntegral <$> elem [-8 .. 8 :: Int]++instance Testable DIFF where+  showOb @a = show (dimsOf @(UN DF a))+  genSome = genSomeDef @'[DF '[], DF '[2], DF '[3], DF '[2, 1]]++instance (KnownListOf KnownNat ns) => TestableType (Point ns) where+  gen = GenNonEmpty (Point <$> traverse (\d -> SV.fromList <$> replicateM d value) (dimsOf @ns))++instance TestingEqShow (Point ns) where+  eqP l r = pure (close l r)+  showP (Point vs) = show (map SV.toList vs)++-- | A dense layer: a matrix and an offset on all the coordinates, and @tanh@.+instance (Ob (a :: DIFF), Ob b) => TestableType (Diff a b) where+  gen = GenNonEmpty do+    let (sa, sb) = (sum (dimsOf @(UN DF a)), sum (dimsOf @(UN DF b)))+    w <- SV.fromList <$> replicateM (sa * sb) value+    c <- SV.fromList <$> replicateM sb value+    pure (layer @(UN DF a) @(UN DF b) w c)++-- | The dense layer with the given matrix, row by row, and offset.+layer+  :: forall as bs+   . (KnownListOf KnownNat as, KnownListOf KnownNat bs) => SV.Vector Double -> SV.Vector Double -> DF as ~> DF bs+layer w c =+  Diff \x ->+    let y = SV.map tanh (preactivation (coordinates x))+    in (fromCoordinates y, \d -> fromCoordinates (transposed (SV.zipWith (\t dz -> dz * (1 - t * t)) y (coordinates d))))+  where+    sa = sum (dimsOf @as)+    sb = sum (dimsOf @bs)+    preactivation v = SV.generate sb \i -> c SV.! i + sum [w SV.! (i * sa + j) * v SV.! j | j <- [0 .. sa - 1]]+    transposed g = SV.generate sa \j -> sum [w SV.! (i * sa + j) * g SV.! i | i <- [0 .. sb - 1]]++instance (Ob (a :: DIFF), Ob b) => TestingEqShow (Diff a b) where+  eqP l r = do+    x <- genP+    dy <- genP+    pure (close (forward l x) (forward r x) && close (backward l x dy) (backward r x dy))+  showP _ = "<differentiable map>"++instance TestableProfunctor (Diff :: CAT DIFF)++instance TestableProfunctor (Rep Forget)
test/Props/Dot.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-orphans #-}  module Props.Dot where
test/Props/OpenHypergraph.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | Open hypergraphs with wires sorted by objects of 'Mat'. Equality is 'isomorphic', so the laws@@ -7,6 +8,7 @@ module Props.OpenHypergraph (test) where  import Control.Monad (replicateM)+import Data.Kind (Constraint, Type) import Data.List qualified as List import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as M@@ -25,26 +27,50 @@   ( Box (..)   , Boxes (..)   , OPENHG+  , Port (..)+  , SIMPLIFY   , SomeArrow+  , SomeHypergraph (..)+  , SomeSort   , Sorted   , WireSorts   , Wires+  , Wiring   , box+  , copyDiscard+  , frobenius+  , frobeniusWith   , isomorphic+  , layered+  , openHypergraph+  , permutations   , prim+  , prim0+  , prim1+  , prim2+  , prim3   , readBack   , sameSort   , simplify+  , simplifyFlat+  , simplifyHypergraph   , someArrow   , sortList   , sortOf+  , substitute+  , substituteWith+  , tracedWith+  , unsafeOpenHypergraph   ) 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 (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..))+import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, Sized (..), cap, cup, traceHG) import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..), singleton)-import Proarrow.Core (CAT, CategoryOf (..), Promonad (..), UN, obj)+import Proarrow.Core (Any, CAT, CategoryOf (..), Promonad (..), UN, obj) import Proarrow.Monoid (Comonoid (..), Monoid (..))+import Proarrow.Object (pattern Objs)+import Proarrow.Optic.Iso (DecidableIso)+import Proarrow.Profunctor.Free (HasFreeK (..)) import Proarrow.Testing   ( SomeOf (..)   , Testable (..)@@ -52,15 +78,18 @@   , TestableType (..)   , TestingEqShow (..)   , check+  , expect   , genNamed   , genSomeDef   , pattern GenNonEmpty   ) import Proarrow.Testing.Laws-import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.Diagrams.Svg (SVG (..), Svg (..), W (Wire), node, render)+import Proarrow.Tools.Diagrams.Svg qualified as Svg import Proarrow.Tools.Einsum (einsum) import Proarrow.Tools.SMC.Examples (hadamardT, matMulT, traceIdxT) import Props.Mat ()+import Props.OpenHypergraph.Generated qualified as Generated import Props.SMC (name)  type OH = OPENHG (MatK Int) String@@ -70,11 +99,39 @@  type B = Wires '[M3] :: OH +-- The full SVG category with unequal sort sizes, to distinguish crossing count from cost.+type Weighted = SUBCAT (Any :: SVG -> Constraint)+type Large :: Weighted+type Large = SUB (S '[Wire "large"])+type Small :: Weighted+type Small = SUB (S '[Wire "small"])++instance Sized Weighted where+  sizeOf @(SUB (S ws)) = product [if wireLabel == "large" then 10 else 1 | (wireLabel, _) <- Svg.wires @ws]++weightedGate :: String -> Large ~> Small+weightedGate title = Sub (node @'[Wire "large"] @'[Wire "small"] title)++diagramParts :: Svg.Diagram -> [Svg.Diagram]+diagramParts = \case+  Svg.Seq a b -> diagramParts a ++ diagramParts b+  Svg.Beside a b -> diagramParts a ++ diagramParts b+  Svg.Trace _ d -> diagramParts d+  d -> [d]++boxNames :: Svg.Diagram -> [String]+boxNames diagram = [title | Svg.Node _ title _ _ <- diagramParts diagram]++wireCrossings :: Svg.Diagram -> Int+wireCrossings diagram =+  sum [length (filter (< i) rest) | Svg.Permute _ _ positions <- diagramParts diagram, i : rest <- List.tails positions]+ test :: TestTree test =   testGroup     "Open hypergraphs"-    [ testCategory @OH+    [ Generated.test+    , testCategory @OH     , testDagger @OH     , testMonoidal_ @OH     , testSymMonoidal_ @OH@@ -85,6 +142,74 @@     , testCompactClosed_ @OH     , testCopyDiscard_ @OH     , testHypergraph_ @OH+    , testTraced_ @OH+    , testProperty "layered read-back tensors independent boxes" do+        let gate = node @'[Wire "a"] @'[Wire "a"] "f"+            graph = prim1 gate ** prim1 gate+        case (simplify permutations graph, simplify (layered permutations) graph) of+          (Right (Str (Svg _ serial)), Right (Str (Svg _ parallel))) ->+            check+              "independent boxes remain sequential"+              (Svg.layoutHeight (Svg.layout Svg.defaultOptions parallel) < Svg.layoutHeight (Svg.layout Svg.defaultOptions serial))+          _ -> testFailed "independent boxes could not be read back"+    , testProperty "read-back keeps carried wires beside and between gates" do+        let gate title = prim1 (node @'[Wire "a"] @'[Wire "a"] title)+            left = gate "g" . gate "f"+            right = gate "j" . gate "i"+            checkLayout :: Wiring SVG -> (a :: SIMPLIFY SVG) ~> b -> Property ()+            checkLayout wiring graph = case simplify wiring graph of+              Left err -> testFailed err+              Right (Str (Svg _ diagram)) -> expect "unnecessary crossings" 0 (wireCrossings diagram)+        sequence_+          [ do+              checkLayout wiring (left ** gate "h")+              checkLayout wiring (left ** gate "h" ** right)+              checkLayout wiring ((left . left . left) ** gate "h" ** (right . right))+          | base <- [permutations, copyDiscard, frobenius]+          , wiring <- [base, layered base]+          ]+    , testProperty "layered read-back prefers crossing small wires" do+        -- Both orders need one crossing. Crossing the inputs costs 100; crossing the outputs+        -- costs 1. List g first so unweighted tie-breaking would retain the expensive order.+        let graph =+              (prim1 (weightedGate "g") ** prim1 (weightedGate "f"))+                . swap @(SIMPLIFY Weighted) @(Wires '[Large]) @(Wires '[Large])+        case simplify (layered permutations) graph of+          Left err -> testFailed err+          Right (Str (Sub (Svg _ diagram))) -> expect "weighted box order" ["f", "g"] (boxNames diagram)+    , testProperty "Frobenius read-back preserves custom swap weights" do+        let gate title = prim1 (node @'[Wire "large"] @'[Wire "small"] title)+            graph =+              (gate "g" ** gate "f")+                . swap @(SIMPLIFY SVG) @(Wires '[S '[Wire "large"]]) @(Wires '[S '[Wire "large"]])+            -- SVG's Sized weights are uniform. These weights favor crossing after both boxes.+            custom = frobeniusWith (\s -> if sameSort s (Some @(S '[Wire "large"])) then 10 else 1)+            afterBox = takeWhile (\case Svg.Node{} -> False; _ -> True) . reverse+            checkWeights :: Wiring SVG -> Int -> Property ()+            checkWeights wiring expected = case simplify wiring graph of+              Left err -> testFailed err+              Right (Str (Svg _ diagram)) ->+                expect "crossing after the last box" expected (sum (map wireCrossings (afterBox (diagramParts diagram))))+        sequence_+          [ checkWeights wiring expected+          | (wiring, expected) <- [(frobenius, 0), (layered frobenius, 0), (custom, 1), (layered custom, 1)]+          ]+    , testProperty "state contraction routing removes crossings" do+        let graph :: Either String ((Wires '[] :: OPENHG SVG String) ~> Wires '[A, A])+            graph =+              openHypergraph+                (replicate 3 (Some @A))+                []+                [0, 1]+                [Box "A" [] [2, 0, 1], Box "B" [] [0, 1, 2], Box "C" [] [0, 2, 0]]+            state :: String -> SomeArrow SVG+            state title = someArrow @'[] @'[A, A, A] (Str (node @'[Svg.I] @'[Wire "A", Wire "A", Wire "A"] title))+        case graph >>= readBack frobenius state of+          Left err -> testFailed err+          Right (Str (Svg _ diagram)) -> do+            -- The previous boundary orders needed ten crossings in the same ((A,B),C) tree.+            expect "crossings" 8 (wireCrossings diagram)+            expect "tensor order" ["A", "B", "C"] (boxNames diagram)     , testGroup         "the Frobenius laws"         [ testProperty "matrix multiplication in index notation is composition" $@@ -105,11 +230,342 @@             check "not isomorphic" (isomorphic (unStr (einsum @"ij,jk" (name f) (name h))) (unStr (name (h . f))))         ]     , testGroup+        "substitution"+        [ testProperty "identity substitution" $ do+            actual <- substituteOr (\x -> if x == "f" then SomeHypergraph f else SomeHypergraph h) (h . f)+            expectGraph "same diagram" (h . f) actual+        , testProperty "substitution composes" $ do+            let twice x = SomeHypergraph (box @_ @'[M2] @'[M2] x . box @_ @'[M2] @'[M2] x)+            first <- substituteOr twice g+            actual <- substituteOr twice first+            direct <- substituteOr (\_ -> SomeHypergraph (g . g . g . g)) g+            expectGraph "two stages" direct actual+        , testProperty "preserves composition" $ do+            let replace _ = SomeHypergraph (g' . g')+            actual <- substituteOr replace (g . g)+            single <- substituteOr replace g+            expectGraph "composition" (single . single) actual+        , testProperty "preserves tensor" $ do+            let replace _ = SomeHypergraph (g' . g')+            actual <- substituteOr replace (g ** g)+            single <- substituteOr replace g+            expectGraph "tensor" (single ** single) actual+        , testProperty "identity replacement merges nodes" $ do+            actual <- substituteOr (\_ -> SomeHypergraph (obj @I)) (g . g)+            expectGraph "identity" (obj @I) actual+        , testProperty "repeated ports and shared nodes" $ do+            actual <- substituteOr (\_ -> SomeHypergraph (obj @I)) (hadamardT g g)+            expectGraph "special Frobenius algebra" (obj @I) actual+        , testProperty "copy and discard replacements" $ do+            let copy = box @_ @'[M2] @'[M2, M2] "copy"+                discard = box @_ @'[M2] @'[] "drop"+                replace x = if x == "copy" then SomeHypergraph (comult @I) else SomeHypergraph (counit @I)+            actual <- substituteOr replace ((obj @I ** discard) . copy)+            expectGraph "counit law" (rightUnitorInv @OH @I) actual+        , testProperty "feedback becomes an isolated loop" $ do+            actual <- substituteOr (\_ -> SomeHypergraph (obj @I)) (traceIdxT g)+            expectGraph "closed loop" (counit @I . mempty @I) actual+        , testProperty "replacement keeps isolated nodes" $ do+            let loop = counit @I . mempty @I+            actual <- substituteOr (\_ -> SomeHypergraph (g ** loop)) g+            expectGraph "loop beside box" (g ** loop) actual+        , testProperty "rejects a different arity" $+            expectFailure "arity" (substitute (\_ -> SomeHypergraph (comult @I)) g)+        , testProperty "rejects a different sort" $+            expectFailure "sorts" (substitute (\_ -> SomeHypergraph (obj @B)) g)+        , testProperty "empty diagrams keep their nodes" $ do+            let graph = counit @I . mempty @I+            actual <- substituteOr (\_ -> error "no boxes") graph+            expectGraph "closed loop" graph actual+        , testProperty "circuit expansion commutes with interpretation" $ do+            hm <- genNamed @(M2 ~> M2) "H"+            zm <- genNamed @(M2 ~> M2) "Z"+            let gate x = box @_ @'[M2] @'[M2] x+                circuit = gate "X" . gate "H"+                expand x = SomeHypergraph (if x == "X" then gate "H" . gate "Z" . gate "H" else gate x)+                interpret x = someArrow (singleton (case x of "H" -> hm; "Z" -> zm; _ -> hm . zm . hm))+            expanded <- substituteOr expand circuit+            expectGraph "H-Z-H decomposition" (gate "H" . gate "Z" . gate "H" . gate "H") expanded+            before <- readBackOr interpret circuit+            after <- readBackOr interpret expanded+            expect "same matrix" (unMat before) (unMat after)+        , testProperty "replacement labels can have a different type" $ do+            actual <- substituteOr (\_ -> SomeHypergraph (box @Int @'[M2] @'[M2] 1)) g+            expectGraph "relabelled box" (box @Int @'[M2] @'[M2] 1) actual+        , testProperty "nullary boxes can add a closed component" $ do+            let emptyBox = box @_ @'[] @'[] "loop"+            actual <- substituteOr (\_ -> SomeHypergraph (counit @I . mempty @I)) emptyBox+            expectGraph "closed component" (counit @I . mempty @I) actual+        , testProperty "separate replacement nodes remain separate" $ do+            let replacement = unsafeOpenHypergraph @String @'[M2] @'[M2] (sortList @_ @'[M2, M2]) [0] [1] []+            actual <- substituteOr (\_ -> SomeHypergraph replacement) g+            expectGraph "discard then create" (mempty @I . counit @I) actual+        ]+    , testGroup+        "sort expansion"+        [ testProperty "singleton expansion agrees with substitution" $ do+            let replace x = if x == "f" then SomeHypergraph f else SomeHypergraph h+            expected <- substituteOr replace (h . f)+            expectExpanded expected (substituteWith (: []) replace (h . f))+        , testProperty "empty expansion removes wires but keeps boxes" $+            expectExpanded+              (emptyGate "g" . emptyGate "g")+              (substituteWith (const []) (SomeHypergraph . emptyGate) (g . g))+        , testProperty "empty expansion removes isolated loops" $+            expectExpanded+              (obj @(Unit :: OH))+              (substituteWith (const []) (\_ -> error "no boxes") (counit @I . mempty @I))+        , testProperty "multiple wires preserve composition" $+            expectExpanded+              (pairGate "g" . pairGate "g")+              (substituteWith pairSorts (SomeHypergraph . pairGate) (g . g))+        , testProperty "multiple wires preserve tensor" $+            expectExpanded+              (pairGate "g" ** pairGate "g'")+              (substituteWith pairSorts (SomeHypergraph . pairGate) (g ** g'))+        , testProperty "expanded copies keep boundary order" $+            expectExpanded+              (comult @(I ** B))+              (substituteWith pairSorts (\_ -> error "no boxes") (comult @I))+        , testProperty "expanded repeated ports share their nodes" $+            expectExpanded+              (hadamardT (pairGate "g") (pairGate "g"))+              (substituteWith pairSorts (SomeHypergraph . pairGate) (hadamardT g g))+        , testProperty "feedback expands into two loops" $+            expectExpanded+              (traceIdxT (pairGate "g"))+              (substituteWith pairSorts (SomeHypergraph . pairGate) (traceIdxT g))+        , testProperty "isolated nodes expand independently" $+            expectExpanded+              (counit @(I ** B) . mempty @(I ** B))+              (substituteWith pairSorts (\_ -> error "no boxes") (counit @I . mempty @I))+        , testProperty "sorts can expand to different lengths" $+            let mapSort s = if sameSort s (Some @M2) then sortList @_ @'[M2, M3] else []+                fi = box @_ @'[M2, M3] @'[] "f"+                hi = box @_ @'[] @'[M2, M3] "h"+                replace x = if x == "f" then SomeHypergraph fi else SomeHypergraph hi+            in expectExpanded (hi . fi) (substituteWith mapSort replace (h . f))+        , testProperty "rejects replacement arity before expansion" $+            expectFailure "arity" (substituteWith pairSorts (\_ -> SomeHypergraph g) g)+        , testProperty "rejects replacement sort order" $+            expectFailure+              "sorts"+              (substituteWith pairSorts (\_ -> SomeHypergraph (box @_ @'[M3, M2] @'[M3, M2] "g")) g)+        , testProperty "can change the kind of sorts" $+            expectExpanded+              (box @String @'[A] @'[A] "g")+              ( substituteWith+                  (const [Some @A])+                  (\x -> SomeHypergraph (box @String @'[A] @'[A] x))+                  g+              )+        ]+    , testGroup+        "symmetric monoidal read-back"+        [ testProperty "composition agrees with hypergraph read-back" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            hm <- genNamed @(M3 ~> M2) "h"+            let interp x = if x == "f" then someArrow (singleton fm) else someArrow (singleton hm)+            expectReadBack permutations interp (h . f)+        , testProperty "parallel boxes agree with hypergraph read-back" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            expectReadBack permutations (const (someArrow (singleton fm))) (f ** f)+        , testProperty "permutations need no boxes" $+            case readBack permutations (\_ -> error "no boxes") (swap @OH @I @B) of+              Left err -> testFailed err+              Right (Str actual) -> expect "swap" (unMat (swap @(MatK Int) @M2 @M3)) (unMat actual)+        , testProperty "nullary boxes and scalar components" $+            let state = box @String @'[] @'[M2] "state"+                finish = box @String @'[M2] @'[] "finish"+                scalar = box @String @'[] @'[] "scalar"+                interp x = case x of+                  "state" -> someArrow @'[] @'[M2] (Str (mempty @M2))+                  "finish" -> someArrow @'[M2] @'[] (Str (counit @M2))+                  _ -> someArrow @'[] @'[] (Str (obj @(Unit :: MatK Int)))+            in case readBack permutations interp ((finish . state) ** scalar) of+                 Left err -> testFailed err+                 Right (Str actual) -> expect "scalar" (unMat (counit @M2 . mempty @M2)) (unMat actual)+        , testProperty "rejects copying" $+            expectFailure "consumers" (readBack permutations (\_ -> error "no boxes") (comult @I))+        , testProperty "rejects merging" $+            expectFailure "producer" (readBack permutations (\_ -> error "no boxes") (mappend @I))+        , testProperty "rejects discarding" $+            expectFailure "consumers" (readBack permutations (\_ -> error "no boxes") (counit @I))+        , testProperty "rejects isolated loops" $+            expectFailure "isolated" (readBack permutations (\_ -> error "no boxes") (counit @I . mempty @I))+        , testProperty "rejects a directed cycle" $+            expectFailure "trace" (readBack permutations (const (someArrow (singleton (obj @M2)))) (traceIdxT g))+        , testProperty "rejects an ill-typed box" $+            expectFailure "box" (readBack permutations (const (someArrow (singleton (obj @M2)))) f)+        , testProperty "empty graph reads back as the unit identity" $+            case readBack permutations (\_ -> error "no boxes") (obj @(Unit :: OH)) of+              Left err -> testFailed err+              Right (Str actual) -> expect "unit" (unMat (obj @(Unit :: MatK Int))) (unMat actual)+        ]+    , testGroup+        "copy-discard read-back"+        [ testProperty "sharing between boxes agrees with hypergraph read-back" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            hm <- genNamed @(M3 ~> M2) "h"+            let interp x = if x == "f" then someArrow (singleton fm) else someArrow (singleton hm)+            expectReadBack copyDiscard interp ((h ** h) . comult @B . f)+        , testProperty "repeated inputs release a box only when all are available" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let source = box @String @'[M2] @'[M2] "source"+                join = box @String @'[M2, M2] @'[M2] "join"+                -- Put the dependent box first in the graph's box list.+                graph =+                  unsafeOpenHypergraph @String @'[M2] @'[M2]+                    (sortList @_ @'[M2, M2, M2])+                    [0]+                    [2]+                    [Box "join" [1, 1] [2], Box "source" [0] [1]]+                interp x = if x == "source" then someArrow (singleton gm) else someArrow @'[M2, M2] @'[M2] (Str (mappend @M2))+            expectGraph "dependent box first" (join . comult @I . source) graph+            expectReadBack copyDiscard interp graph+        , testProperty "a shared node survives until its last consumer" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            expectReadBack copyDiscard (const (someArrow (singleton gm))) ((g ** g) . comult @I)+        , testProperty "a node can feed a box and an output boundary" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            expectReadBack copyDiscard (const (someArrow (singleton gm))) ((obj @I ** g) . comult @I)+        , testProperty "unused box outputs are discarded without removing the box" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            expectReadBack copyDiscard (const (someArrow (singleton gm))) (counit @I . g)+        , testProperty "unused box output is discarded before a later box" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            expectReadBack copyDiscard (const (someArrow (singleton gm))) ((counit @I . g) ** g)+        , testProperty "unused boundary inputs are discarded" $+            expectReadBack copyDiscard (\_ -> error "no boxes") (obj @I ** counit @B)+        , testProperty "repeated output ports are copied and permuted" $+            expectReadBack+              copyDiscard+              (\_ -> error "no boxes")+              ( unsafeOpenHypergraph @String @'[M2, M3] @'[M3, M2, M3, M2, M2]+                  (sortList @_ @'[M2, M3])+                  [0, 1]+                  [1, 0, 1, 0, 0]+                  []+              )+        , testProperty "nullary boxes can produce shared values" $+            let state = box @String @'[] @'[M2] "state"+            in expectReadBack copyDiscard (const (someArrow @'[] @'[M2] (Str (mempty @M2)))) (comult @I . state)+        , testProperty "empty graph" $+            expectReadBack copyDiscard (\_ -> error "no boxes") (obj @(Unit :: OH))+        , testProperty "rejects merging" $+            expectFailure "producer" (readBack copyDiscard (\_ -> error "no boxes") (mappend @I))+        , testProperty "rejects a node without a producer" $+            expectFailure "producer" (readBack copyDiscard (\_ -> error "no boxes") (mempty @I))+        , testProperty "rejects isolated nodes" $+            expectFailure "isolated" (readBack copyDiscard (\_ -> error "no boxes") (counit @I . mempty @I))+        , testProperty "rejects cycles" $+            expectFailure "trace" (readBack copyDiscard (const (someArrow (singleton (obj @M2)))) (traceIdxT g))+        , testProperty "rejects an ill-typed box" $+            expectFailure "box" (readBack copyDiscard (const (someArrow (singleton (obj @M2)))) f)+        , testProperty "primitive arities compose with ordered ports in a non-strict category" $+            let graph :: (Wires '[Int, Bool, Char] :: SIMPLIFY Type) ~> Wires '[String]+                graph =+                  prim3 (\((n, text), suffix) -> show (n :: Int) ++ text ++ suffix)+                    . (prim2 (\(n, b) -> if b then n + 1 else n - 1) ** prim1 (: []) ** prim0 (const "done"))+            in case simplify permutations graph of+                 Left err -> testFailed err+                 Right (Str actual) -> do+                   expect "true branch and port order" "4!done" (actual (3, (True, '!')))+                   expect "false branch and port order" "2?done" (actual (3, (False, '?')))+        , testProperty "primitive graph executes as a Haskell function with sharing" $+            let inc = prim1 ((+ 1) :: Int -> Int)+                add = prim2 (uncurry (+) :: (Int, Int) -> Int)+            in case simplify copyDiscard (add . comult . inc) of+                 Left err -> testFailed err+                 Right (Str actual) -> expect "shared result" 16 (actual 7)+        ]+    , testGroup+        "independent feedback capability"+        [ testProperty "permutations with trace agree with hypergraph read-back" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            expectReadBack (tracedWith permutations) (const (someArrow (singleton gm))) (traceIdxT g)+        , testProperty "cuts a multi-box cycle" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            hm <- genNamed @(M3 ~> M2) "h"+            let interp x = if x == "f" then someArrow (singleton fm) else someArrow (singleton hm)+                graph = traceIdxT (h . f)+            expectReadBack (tracedWith permutations) interp graph+        , testProperty "disconnected cycles close independently" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let interp = const (someArrow (singleton gm))+                graph = traceIdxT g ** traceIdxT g+            expectReadBack (tracedWith permutations) interp graph+        , testProperty "copying a feedback wire to an output" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let graph =+                  unsafeOpenHypergraph @String @'[] @'[M2]+                    (sortList @_ @'[M2, M2])+                    []+                    [0]+                    [Box "g" [0] [1], Box "g" [1] [0]]+                interp = const (someArrow (singleton gm))+            expectReadBack (tracedWith copyDiscard) interp graph+        , testProperty "copying a producerless feedback wire to an output" $+            let graph = traceHG @I @(Unit :: OH) @I (comult @I . rightUnitor)+            in expectReadBack (tracedWith copyDiscard) (\_ -> error "no boxes") graph+        , testProperty "producerless feedback supplies a box input" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let graph = g . traceHG @I @(Unit :: OH) @I (comult @I . rightUnitor)+            expectReadBack (tracedWith copyDiscard) (const (someArrow (singleton gm))) graph+        , testProperty "repeated cyclic inputs are copied" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let graph =+                  unsafeOpenHypergraph @String @'[] @'[]+                    (sortList @_ @'[M2])+                    []+                    []+                    [Box "g" [0, 0] [0]]+                interp = const (someArrow @'[M2, M2] @'[M2] (Str (mappend @M2 . (gm ** gm))))+            expectReadBack (tracedWith copyDiscard) interp graph+        , testProperty "trace alone still rejects copying" $+            expectFailure "consumers" (readBack (tracedWith permutations) (\_ -> error "no boxes") (comult @I))+        , testProperty "trace alone rejects a producerless state" $+            expectFailure "producer" (readBack (tracedWith permutations) (\_ -> error "no boxes") (mempty @I))+        , testProperty "traced copying still rejects merging" $+            expectFailure "producer" (readBack (tracedWith copyDiscard) (\_ -> error "no boxes") (mappend @I))+        , testProperty "isolated loop is a traced identity" $+            case readBack (tracedWith permutations) (\_ -> error "no boxes") (counit @I . mempty @I) of+              Left err -> testFailed err+              Right (Str actual) -> expect "dimension" (unMat (counit @M2 . mempty @M2)) (unMat actual)+        , testProperty "tracedWith replaces Frobenius feedback" $+            let d = node @'[Wire "A"] @'[Wire "A"] "g"+                graph = traceIdxT (box @_ @'[A] @'[A] "g") :: Wires '[] ~> (Wires '[] :: OPENHG SVG String)+            in case readBack (tracedWith frobenius) (const (someArrow (singleton d))) graph of+                 Left err -> testFailed err+                 Right (Str (Svg _ diagram)) -> check "target trace is missing" ("Trace " `List.isInfixOf` show diagram)+        , testProperty "Frobenius wiring reads an acyclic graph" $ do+            gm <- genNamed @(M2 ~> M2) "g"+            let graph = hadamardT g g+                interp = const (someArrow (singleton gm))+            expectReadBack frobenius interp graph+        , testProperty "Haskell feedback without copying" $+            case simplify (tracedWith permutations) productiveLoop of+              Left err -> testFailed err+              Right (Str actual) -> expect "productive loop" 21 (actual 7)+        , testProperty "Haskell feedback combined with copying" $+            case simplify (tracedWith copyDiscard) (comult . productiveLoop) of+              Left err -> testFailed err+              Right (Str actual) -> expect "shared loop result" (21, 21) (actual 7)+        ]+    , testGroup         "read-back in Mat Int"-        [ testProperty "matrix multiplication in index notation reads back as composition (2, 3)" $ do+        [ testProperty "free hypergraph retraction preserves shared inputs" $ do             fm <- genNamed @(M2 ~> M3) "f"+            let lifted = liftK @CategoryOf @Hypergraph fm+                graph = (lifted ** lifted) . comult @(Wires '[M2])+                actual = retractK @CategoryOf @Hypergraph @(MatK Int) graph+            expect "retracted matrix" (unMat ((fm ** fm) . comult @M2)) (unMat actual)+        , testProperty "rejects a box with other sorts" $+            expectFailure "sorts" (readBack frobenius (const (someArrow (singleton (obj @M2)))) f)+        , 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)))+            let Str m = simplifyHypergraph (matMulT (prim1 fm) (prim1 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"@@ -163,16 +619,45 @@             check "not 3" (unMat m == unMat (counit @M3 . mempty @M3))         ]     , testGroup+        "flat read-back in Mat Int, every box bent into a state"+        [ testProperty "matrix multiplication in index notation is composition (2, 3)" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            gm <- genNamed @(M3 ~> M2) "g"+            let Str m = simplifyFlat (matMulT (prim1 fm) (prim1 gm))+            check "differs from g . f" (unMat m == unMat (gm . fm))+        , testProperty "the trace, a cycle, needs no trace (3)" $ do+            gm <- genNamed @(M3 ~> M3) "g"+            let Str m = simplifyFlat (traceIdxT (prim1 gm))+            check "differs" (unMat m == unMat (traceIdxT gm))+        , testProperty "the entrywise product (2, 3)" $ do+            fm <- genNamed @(M2 ~> M3) "f"+            gm <- genNamed @(M2 ~> M3) "g"+            let Str m = simplifyFlat (hadamardT (prim1 fm) (prim1 gm))+            check "differs" (unMat m == unMat (hadamardT fm gm))+        , 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 Str m =+                  simplifyFlat+                    ( prim1 gm+                        . mappend @(Wires '[M3])+                        . (prim0 am ** prim0 bm)+                    )+            check "differs" (unMat m == unMat (gm . mappend @M3 . (am ** bm) . leftUnitorInv))+        ]+    , 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+            case readBack frobenius (\_ -> 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+              frobenius               (\_ -> 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)@@ -192,15 +677,78 @@ type OM = OH type A = S '[Wire "A"] +-- The feedback equation is u = n : u; only three elements are demanded for the result.+productiveLoop :: (Wires '[Int] :: SIMPLIFY Type) ~> Wires '[Int]+productiveLoop =+  traceHG @(Wires '[[Int]]) @(Wires '[Int]) @(Wires '[Int])+    (prim @'[[Int], Int] @'[[Int], Int] (Str (\(u, n) -> (n : u, sum (take 3 u)))))++pairSorts :: SomeSort (MatK Int) -> [SomeSort (MatK Int)]+pairSorts _ = sortList @_ @'[M2, M3]++pairGate :: String -> Wires '[M2, M3] ~> (Wires '[M2, M3] :: OH)+pairGate = box++emptyGate :: String -> Wires '[] ~> (Wires '[] :: OH)+emptyGate = box++expectExpanded+  :: forall {s} l as bs+   . (Eq l, DecidableIso s)+  => (Wires as :: OPENHG s l) ~> Wires bs+  -> Either String (SomeHypergraph s l)+  -> Property ()+expectExpanded expected@Objs result = case result of+  Left err -> testFailed err+  Right (SomeHypergraph (DecCospan @c (Sub (FinHask l)) (Sub (FinHask r)) (Boxes boxes))) ->+    let unPort (Port i) = i+    in case openHypergraph @l @as @bs+         (sortList @_ @(WireSorts (DC c)))+         (fmap unPort (M.elems l))+         (fmap unPort (M.elems r))+         (fmap (fmap unPort) boxes) of+         Left err -> testFailed err+         Right actual -> expectGraph "expanded diagram" expected actual++expectFailure :: String -> Either String a -> Property ()+expectFailure reason result = case result of+  Left err -> check ("wrong error: " ++ err) (reason `List.isInfixOf` err)+  Right _ -> testFailed ("expected an error about " ++ reason)++expectGraph :: forall {s} l a b. (Eq l, DecidableIso s) => String -> (a :: OPENHG s l) ~> b -> a ~> b -> Property ()+expectGraph message expected actual = check message (isomorphic expected actual)++substituteOr+  :: forall l a b+   . (String -> SomeHypergraph (MatK Int) l)+  -> (a :: OH) ~> b+  -> Property (Wires (WireSorts a) ~> (Wires (WireSorts b) :: OPENHG (MatK Int) l))+substituteOr replace graph = case substitute replace graph of+  Left err -> testFailed err+  Right result -> pure result+ -- | 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+readBackOr interp t = case readBack frobenius interp t of   Right (Str m) -> pure m   Left e -> testFailed e++-- Compare against the full reader in a non-cartesian target: discarded boxes can still matter.+expectReadBack+  :: forall a b+   . Wiring (MatK Int)+  -> (String -> SomeArrow (MatK Int))+  -> (a :: OH) ~> b+  -> Property ()+expectReadBack wiring interp graph = do+  Mat values <- readBackOr interp graph+  case readBack wiring interp graph of+    Left err -> testFailed err+    Right (Str actual) -> expect "matrix" values (unMat actual)  instance Testable OH where   showOb @a = "Wires " ++ show (fmap (\(Some @x) -> sizeOf @(MatK Int) @x) (sortList @(MatK Int) @(WireSorts a)))
+ test/Props/OpenHypergraph/Generated.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Interpret typed free diagrams directly in Mat Integer and read their open hypergraphs+-- back into TNET Int. Compare entries modulo the machine word size. The generator changes+-- boundaries only by typed composition, tensor and trace; it never builds raw node lists.+-- Three wires of dimensions two or three keep the independent dense reference small.+module Props.OpenHypergraph.Generated (test) where++import Data.Foldable (toList)+import Data.Kind (Constraint, Type)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Type.Equality ((:~:) (..))+import Data.Type.Nat (Nat2, Nat3)+import Test.Falsify (Gen, Property, testFailed)+import Test.Falsify qualified as F+import Test.Falsify.Generator (elem, oneof)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude hiding (Monoid, elem, fmap, id, mappend, mempty, (**), (.))+import Prelude qualified as P++import Proarrow.Category.Enriched.Thin (Member (..), memberIndex)+import Proarrow.Category.Instance.Bool (BOOL (..))+import Proarrow.Category.Instance.Discrete (DISCRETE (..))+import Proarrow.Category.Instance.Discrete qualified as Discrete+import Proarrow.Category.Instance.Free (FREE (..), Free, emb, fold)+import Proarrow.Category.Instance.Mat (Mat (..), MatK (..))+import Proarrow.Category.Instance.OpenHypergraph+  ( SIMPLIFY+  , Wires+  , Wiring+  , copyDiscard+  , frobenius+  , layered+  , permutations+  , prim1+  , simplify+  , tracedWith+  )+import Proarrow.Category.Instance.TensorNetwork (TNET (..))+import Proarrow.Category.Instance.TensorNetwork qualified as TNet+import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..), SymMonoidal (..), UnitF, type (**!))+import Proarrow.Category.Monoidal.CompactClosed (CompactClosedStructures)+import Proarrow.Category.Monoidal.Hypergraph (traceHG)+import Proarrow.Category.Monoidal.Strictified (Strictified (..), type (++))+import Proarrow.Core (CAT, CategoryOf (..), Kind, Promonad (..), UN, obj, type (+->))+import Proarrow.Functor (FunctorForRep (..))+import Proarrow.Monoid (Comonoid (..), Monoid (..), Supplies)+import Proarrow.Object (pattern Objs)+import Proarrow.Profunctor.Representable (Rep)+import Proarrow.Testing (expect, genNamed)+import Props.Mat ()++type M2 :: MatK Integer+type M2 = M Nat2+type M3 :: MatK Integer+type M3 = M Nat3++type Dimension :: BOOL -> MatK Integer+type family Dimension a where+  Dimension FLS = M2+  Dimension TRU = M3++-- The discrete base has two object sorts, with independent endomorphisms and rectangular gates.+data Gate :: CAT (DISCRETE BOOL) where+  Gate :: forall a b. String -> Mat (Dimension a) (Dimension b) -> Gate (D a) (D b)++instance Show (Gate a b) where+  show (Gate name _) = name++data family Dense :: DISCRETE BOOL +-> MatK Integer+instance FunctorForRep Dense where+  type Dense @ a = Dimension (UN D a)+  fmap @a Discrete.Refl = case memberIndex @a of+    Here -> obj @M2+    There Here -> obj @M3++type NetworkDimension :: BOOL -> TNET Int+type family NetworkDimension a where+  NetworkDimension FLS = TN '[2]+  NetworkDimension TRU = TN '[3]++data family Graph :: DISCRETE BOOL +-> SIMPLIFY (TNET Int)+instance FunctorForRep Graph where+  type Graph @ a = Wires '[NetworkDimension (UN D a)]+  fmap @a Discrete.Refl = case memberIndex @a of+    Here -> obj @(Wires '[TN '[2]])+    There Here -> obj @(Wires '[TN '[3]])++denseGate :: Gate a b -> Dimension (UN D a) ~> Dimension (UN D b)+denseGate (Gate _ m) = m++networkGate :: forall a b. (Ob a, Ob b) => Gate a b -> NetworkDimension (UN D a) ~> NetworkDimension (UN D b)+networkGate g = case (memberIndex @a, memberIndex @b) of+  (Here, Here) -> TNet.fromEntries rows+  (Here, There Here) -> TNet.fromEntries rows+  (There Here, Here) -> TNet.fromEntries rows+  (There Here, There Here) -> TNet.fromEntries rows+  where+    rows :: [[Int]] = map (map fromInteger) (entries (denseGate g))++type Structures :: [Kind -> Constraint]+type Structures = CompactClosedStructures ++ '[Supplies Monoid, Supplies Comonoid]+type Diagram :: Kind+type Diagram = FREE Structures Gate++type A :: Diagram+type A = EMB (D FLS)+type B :: Diagram+type B = EMB (D TRU)++type Shape :: Diagram -> Type+data Shape a where+  UnitShape :: Shape UnitF+  TwoShape :: Shape A+  ThreeShape :: Shape B+  TensorShape :: (Ob a, Ob b) => Shape a -> Shape b -> Shape (a **! b)++data SomeDiagram where+  SomeDiagram :: Shape a -> Shape b -> Free a b -> SomeDiagram++instance Show SomeDiagram where+  show (SomeDiagram a b f) = showShape a ++ " -> " ++ showShape b ++ ": " ++ show f++showShape :: Shape a -> String+showShape UnitShape = "I"+showShape TwoShape = "2"+showShape ThreeShape = "3"+showShape (TensorShape a b) = "(" ++ showShape a ++ " ** " ++ showShape b ++ ")"++width :: Shape a -> Int+width UnitShape = 0+width TwoShape = 1+width ThreeShape = 1+width (TensorShape a b) = width a + width b++sameShape :: Shape a -> Shape b -> Maybe (a :~: b)+sameShape UnitShape UnitShape = Just Refl+sameShape TwoShape TwoShape = Just Refl+sameShape ThreeShape ThreeShape = Just Refl+sameShape (TensorShape a b) (TensorShape c d) = do+  Refl <- sameShape a c+  Refl <- sameShape b d+  pure Refl+sameShape _ _ = Nothing++data Fragment = Symmetric | Copying | TracedSymmetric | TracedCopying | Hypergraphs+  deriving (Eq)++copies :: Fragment -> Bool+copies Symmetric = False+copies TracedSymmetric = False+copies _ = True++traces :: Fragment -> Bool+traces Symmetric = False+traces Copying = False+traces _ = True++-- Each step is an existing Free morphism, not another syntax tree to interpret.+data Step a where+  Step :: Shape b -> Free a b -> Step a++genStep :: forall a. (Ob a) => Fragment -> NonEmpty SomeDiagram -> Int -> Shape a -> Gen (Step a)+genStep fragment gates capacity shape = oneof (pure (Step shape id) :| options)+  where+    options =+      [ pure (Step (TensorShape UnitShape shape) leftUnitorInv)+      , pure (Step (TensorShape shape UnitShape) rightUnitorInv)+      ]+        ++ [pure (Step target f) | SomeDiagram source target f <- toList gates, Just Refl <- [sameShape source shape]]+        ++ case shape of+          TensorShape a b ->+            [ pure (Step (TensorShape b a) swap)+            , do+                Step a' f@Objs <- genStep fragment gates (capacity - width b) a+                pure (Step (TensorShape a' b) (f ** obj))+            , do+                Step b' f@Objs <- genStep fragment gates (capacity - width a) b+                pure (Step (TensorShape a b') (obj ** f))+            ]+              ++ [pure (Step a mappend) | fragment == Hypergraphs, Just Refl <- [sameShape a b]]+              ++ case (a, b) of+                (UnitShape, _) -> [pure (Step b leftUnitor)]+                (_, UnitShape) -> [pure (Step a rightUnitor)]+                (TensorShape x y, _) -> [pure (Step (TensorShape x (TensorShape y b)) associator)]+                (_, TensorShape y z) -> [pure (Step (TensorShape (TensorShape a y) z) associatorInv)]+                _ -> []+          UnitShape+            | fragment == Hypergraphs+            , capacity > 0 ->+                [pure (Step TwoShape mempty), pure (Step ThreeShape mempty)]+          _ -> []+        ++ [pure (Step UnitShape counit) | copies fragment]+        ++ [pure (Step (TensorShape shape shape) comult) | copies fragment, 2 * width shape <= capacity]++genDiagram :: Fragment -> NonEmpty SomeDiagram -> Int -> Gen SomeDiagram+genDiagram fragment gates = grow+  where+    starts =+      [ SomeDiagram UnitShape UnitShape id+      , SomeDiagram TwoShape TwoShape id+      , SomeDiagram ThreeShape ThreeShape id+      , SomeDiagram (TensorShape TwoShape ThreeShape) (TensorShape TwoShape ThreeShape) id+      , SomeDiagram (TensorShape ThreeShape TwoShape) (TensorShape ThreeShape TwoShape) id+      ]+    grow 0 = oneof (elem gates :| [elem starts])+    grow n = do+      SomeDiagram a b f@Objs <- grow (n - 1)+      let extend = do+            Step c g <- genStep fragment gates 3 b+            pure (SomeDiagram a c (g . f))+          tensor =+            [ do+                SomeDiagram c d g@Objs <- elem gates+                left <- elem [False, True]+                pure $+                  if left+                    then SomeDiagram (TensorShape a c) (TensorShape b d) (f ** g)+                    else SomeDiagram (TensorShape c a) (TensorShape d b) (g ** f)+            | max (width a) (width b) < 3+            ]+          feedback = case (a, b) of+            (TensorShape u x, TensorShape v y)+              | traces fragment+              , width u == 1+              , Just Refl <- sameShape u v ->+                  [pure (SomeDiagram x y (traceHG f))]+            _ -> []+      oneof (extend :| (tensor ++ feedback))++primitives :: Property (NonEmpty SomeDiagram)+primitives = do+  f22 <- integerMatrix <$> genNamed @(Mat (M Nat2 :: MatK Int) (M Nat2)) "f22"+  g22 <- integerMatrix <$> genNamed @(Mat (M Nat2 :: MatK Int) (M Nat2)) "g22"+  f23 <- integerMatrix <$> genNamed @(Mat (M Nat2 :: MatK Int) (M Nat3)) "f23"+  f32 <- integerMatrix <$> genNamed @(Mat (M Nat3 :: MatK Int) (M Nat2)) "f32"+  f33 <- integerMatrix <$> genNamed @(Mat (M Nat3 :: MatK Int) (M Nat3)) "f33"+  g33 <- integerMatrix <$> genNamed @(Mat (M Nat3 :: MatK Int) (M Nat3)) "g33"+  pure+    [ SomeDiagram TwoShape TwoShape (emb (Gate @FLS @FLS "f22" f22))+    , SomeDiagram TwoShape TwoShape (emb (Gate @FLS @FLS "g22" g22))+    , SomeDiagram TwoShape ThreeShape (emb (Gate @FLS @TRU "f23" f23))+    , SomeDiagram ThreeShape TwoShape (emb (Gate @TRU @FLS "f32" f32))+    , SomeDiagram ThreeShape ThreeShape (emb (Gate @TRU @TRU "f33" f33))+    , SomeDiagram ThreeShape ThreeShape (emb (Gate @TRU @TRU "g33" g33))+    ]++-- Reuse the small integer generators, then compute in an unbounded ring.+integerMatrix :: Mat (M m :: MatK Int) (M n) -> Mat (M m :: MatK Integer) (M n)+integerMatrix (Mat rows) = Mat (P.fmap (P.fmap toInteger) rows)++entries :: Mat (a :: MatK Integer) b -> [[Integer]]+entries (Mat rows) = map toList (toList rows)++-- TNET varies the rightmost wire fastest; Mat's tensor varies the left factor fastest.+-- For each TNET boundary index, give the corresponding index of the dense reference.+basisOrder :: Shape a -> [Int]+basisOrder UnitShape = [0]+basisOrder TwoShape = [0, 1]+basisOrder ThreeShape = [0, 1, 2]+basisOrder (TensorShape a b) =+  let left = basisOrder a+  in [i + length left * j | i <- left, j <- basisOrder b]++compareReadBack :: [(String, Wiring (TNET Int))] -> SomeDiagram -> Property ()+compareReadBack readers diagram@(SomeDiagram a b f) = do+  let dense = entries (fold @Structures @(Rep Dense) denseGate f)+      expected :: [[Int]] = [[fromInteger (dense !! i !! j) | j <- basisOrder a] | i <- basisOrder b]+      graph = fold @Structures @(Rep Graph) (prim1 . networkGate) f+  mapM_+    ( \(name, wiring) -> case simplify wiring graph of+        Left err -> testFailed (name ++ ": " ++ err ++ "\n" ++ show diagram) :: Property ()+        Right (Str actual) -> expect (name ++ ": " ++ show diagram) expected (TNet.entries actual)+    )+    (readers ++ [("layered " ++ name, layered wiring) | (name, wiring) <- readers])++test :: TestTree+test =+  testGroup+    "generated diagrams"+    [ testProperty name $ do+        gates <- primitives+        size <- F.gen (elem [3 .. 6])+        diagram <- F.gen (genDiagram fragment gates size)+        compareReadBack [(name, wiring), ("hypergraph", other)] diagram+    | (name, fragment, wiring, other) <-+        [ ("symmetric monoidal", Symmetric, permutations, frobenius)+        , ("copy/discard", Copying, copyDiscard, frobenius)+        , ("traced symmetric monoidal", TracedSymmetric, tracedWith permutations, frobenius)+        , ("traced copy/discard", TracedCopying, tracedWith copyDiscard, frobenius)+        , ("hypergraph", Hypergraphs, frobenius, tracedWith frobenius)+        ]+    ]++-- For GHC 9.10+instance MonadFail Gen where+  fail = error
test/Props/SMC.hs view
@@ -1,10 +1,15 @@ {-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE RecursiveDo #-}  -- | 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 Control.Arrow qualified as A+import Control.Monad.Fix (MonadFix)+import Data.Bool (bool) import Data.Containers.ListUtils (nubOrd) import Data.Foldable (toList) import Data.Map.Strict qualified as M@@ -18,14 +23,18 @@ import Proarrow.Category.Instance.FinRel (FINREL (..)) import Proarrow.Category.Instance.Mat (Mat (..), MatK (..)) import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor (..))+import Proarrow.Category.Monoidal.Closed qualified as Closed import Proarrow.Category.Monoidal.Hypergraph (Hypergraph, cap, cup) import Proarrow.Category.Monoidal.Strictified (Fold, Strictified (..)) import Proarrow.Core (CategoryOf (..), Promonad (..), obj, (\\))+import Proarrow.Functor (Prelude (..)) import Proarrow.Monoid (Comonoid (..), Monoid (..))-import Proarrow.Testing (check, genNamed)+import Proarrow.Profunctor.Instance.Arrow (Arr (..))+import Proarrow.Profunctor.Instance.Star (unStar, pattern Star)+import Proarrow.Testing (check, expect, 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 (SYN (..), delta, ifThenElse, liftF, returnA, sumOver, toSMC, toSMC1, unit, (*^), (-<), (^*)) import Proarrow.Tools.SMC qualified as SMC import Proarrow.Tools.SMC.Examples (hadamardT, matMulT, traceIdxT) import Props.FinRel ()@@ -40,7 +49,7 @@  -- | 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+transposeT f = toSMC1 \j -> sumOver @(F M2) \i -> delta (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]@@ -50,17 +59,220 @@ matMulE :: EinsumType "ij,jk" '[ '[M2, M3], '[M3, M2]] matMulE = einsum @"ij,jk" +-- The signature checks that case analysis needs ArrowChoice without ArrowApply.+choiceT+  :: (A.ArrowChoice arr)+  => arr (Either Int Bool) (Either Int Bool)+  -> arr (Int, Int) Int+  -> arr (Bool, Int) Int+  -> arr ((Either Int Bool, Int), Int) Int+choiceT select left right = unArr $ SMC.proc @((F (Either Int Bool) :** F Int) :** F Int) @(F Int) \((tag, n), m) -> SMC.do+  s <- Arr select -< tag+  if s+    then \x -> Arr left -< (x, n)+    else \b -> Arr right -< (b, m)++-- Reuse both the input and a bound value across later binds, then mix all their depths.+reuseAcrossBindsT+  :: (A.Arrow arr)+  => arr Int Int+  -> arr Int Int+  -> arr (Int, Int) Int+  -> arr Int ((Int, Int), (Int, Int))+reuseAcrossBindsT first second combine = unArr $ SMC.proc @(F Int) @(F ((Int, Int), (Int, Int))) \n -> SMC.do+  x <- Arr first -< n+  y <- Arr second -< x+  z <- Arr combine -< (x, n)+  returnA -< ((n, x), (y, z))++injectLeftT :: (A.Arrow arr) => arr Int Int -> arr Int (Either Int Bool)+injectLeftT f = unArr $ SMC.proc @(F Int) @(F Int :|| F Bool) \x -> SMC.inl (Arr f -< x)++injectRightT :: (A.Arrow arr) => arr Bool Bool -> arr Bool (Either Int Bool)+injectRightT f = unArr $ SMC.proc @(F Bool) @(F Int :|| F Bool) \x -> SMC.inr (Arr f -< x)++-- The signature checks that feedback needs ArrowLoop without ArrowApply or ArrowChoice.+arrowLoopT+  :: (A.ArrowLoop arr)+  => arr Int Int+  -> arr (Int, [Int]) (Int, [Int])+  -> arr Int Int+  -> arr Int Int+arrowLoopT before body after = unArr $ SMC.proc @(F Int) @(F Int) \n -> SMC.do+  x <- Arr before -< n+  y <- SMC.loop @(F [Int]) @(F Int) \u -> SMC.recast (Arr body -< (x, u))+  Arr after -< y++arrowRecT+  :: (A.ArrowLoop arr)+  => arr Int Int+  -> arr (Int, [Int]) (Int, [Int])+  -> arr Int Int+  -> arr Int Int+arrowRecT before body after = unArr $ SMC.proc @(F Int) @(F Int) \n -> SMC.do+  x <- Arr before -< n+  rec (y, u) <- Arr body -< (x, u)+  Arr after -< y++arrowRecCopyT :: (A.ArrowLoop arr) => arr (Int, [Int]) ([Int], [Int]) -> arr Int ([Int], [Int])+arrowRecCopyT body = unArr $ SMC.proc @(F Int) @(F ([Int], [Int])) \n -> SMC.do+  rec (ys, u) <- Arr body -< (n, u)+  Arr (A.second (A.arr (take 3))) -< (ys, u)++arrowRecDropT :: (A.ArrowLoop arr) => arr (Int, [Int]) (Int, [Int]) -> arr Int [Int]+arrowRecDropT body = unArr $ SMC.proc @(F Int) @(F [Int]) \n -> SMC.do+  rec (_ignored, u) <- Arr body -< (n, u)+  Arr (A.arr (take 3)) -< u++arrowRecDiscardT :: (A.ArrowLoop arr) => arr Int Int -> arr Int () -> arr Int ()+arrowRecDiscardT body after = unArr $ SMC.proc @(F Int) @(F ()) \n -> SMC.do+  rec _ignored <- Arr body -< n+  z <- Arr after -< n+  returnA -< z++starLoopT+  :: (MonadFix m)+  => (Int -> m Int)+  -> ((Int, [Int]) -> m (Int, [Int]))+  -> (Int -> m Int)+  -> Int+  -> m Int+starLoopT before body after =+  unPrelude+    . unStar+      ( SMC.proc @(F Int) @(F Int) \n -> SMC.do+          x <- Star (Prelude . before) -< n+          y <- SMC.loop @(F [Int]) @(F Int) \u -> SMC.recast (Star (Prelude . body) -< (x, u))+          Star (Prelude . after) -< y+      )++starRecT+  :: (MonadFix m)+  => (Int -> m Int)+  -> ((Int, [Int]) -> m (Int, [Int]))+  -> (Int -> m Int)+  -> Int+  -> m Int+starRecT before body after =+  unPrelude+    . unStar+      ( SMC.proc @(F Int) @(F Int) \n -> SMC.do+          x <- Star (Prelude . before) -< n+          rec (y, u) <- Star (Prelude . body) -< (x, u)+          Star (Prelude . after) -< y+      )+ -- `\_ -> 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+    [ testProperty "reuse across binds preserves variable identities and runs each effect once" $ do+        n <- genNamed @Int "input"+        let first = A.Kleisli (\x -> (["first"], x + 1))+            second = A.Kleisli (\x -> (["second"], x * 2))+            combine = A.Kleisli (\(x, input) -> (["combine"], x - input))+            run :: Int -> ([String], ((Int, Int), (Int, Int)))+            run = A.runKleisli (reuseAcrossBindsT first second combine)+        expect "values and effects" (["first", "second", "combine"], ((n, n + 1), (2 * (n + 1), 1))) (run n)+    , testGroup+        "ArrowChoice"+        [ testProperty "only the selected branch runs with its captured variable" $ do+            let select = A.Kleisli (["select"],)+                left = A.Kleisli (\(x, n) -> (["left"], x + n))+                right = A.Kleisli (\(b, m) -> (["right"], bool (negate m) m b))+                run :: ((Either Int Bool, Int), Int) -> ([String], Int)+                run = A.runKleisli (choiceT select left right)+            expect "left context" (["select", "left"], 13) (run ((Left 3, 10), 100))+            expect "right context" (["select", "right"], 100) (run ((Right True, 10), 100))+            expect "right payload" (["select", "right"], -100) (run ((Right False, 10), 100))+        , testProperty "pure injections preserve the preceding effect" $ do+            let left :: Int -> ([String], Either Int Bool)+                left = A.runKleisli (injectLeftT (A.Kleisli (["left input"],)))+                right :: Bool -> ([String], Either Int Bool)+                right = A.runKleisli (injectRightT (A.Kleisli (["right input"],)))+            expect "left injection" (["left input"], Left 3) (left 3)+            expect "right injection" (["right input"], Right True) (right True)+        ]+    , testGroup+        "ArrowLoop"+        [ testProperty "lazy feedback preserves surrounding effects and runs the body once" $ do+            n <- genNamed @Int "input"+            let before = A.Kleisli (\x -> (["before"], x + 1))+                body = A.Kleisli (\(x, u) -> (["loop"], (sum (take 3 u), x : u)))+                after = A.Kleisli (\x -> (["after"], x - 2))+                run :: Int -> ([String], Int)+                run = A.runKleisli (arrowLoopT before body after)+            expect "feedback and effects" (["before", "loop", "after"], 3 * (n + 1) - 2) (run n)+        , testProperty "recursive do preserves surrounding effects and runs the body once" $ do+            n <- genNamed @Int "input"+            let before = A.Kleisli (\x -> (["before"], x + 1))+                body = A.Kleisli (\(x, u) -> (["rec"], (sum (take 3 u), x : u)))+                after = A.Kleisli (\x -> (["after"], x - 2))+                run :: Int -> ([String], Int)+                run = A.runKleisli (arrowRecT before body after)+            expect "recursive feedback and effects" (["before", "rec", "after"], 3 * (n + 1) - 2) (run n)+        , testProperty "recursive do copies feedback values and discards unused outputs" $ do+            n <- genNamed @Int "input"+            let copyBody = A.Kleisli (\(x, u) -> (["copy"], (take 2 u, x : u)))+                dropBody = A.Kleisli (\(x, u) -> (["discard"], (x, x : u)))+                runCopy :: Int -> ([String], ([Int], [Int]))+                runCopy = A.runKleisli (arrowRecCopyT copyBody)+                runDrop :: Int -> ([String], [Int])+                runDrop = A.runKleisli (arrowRecDropT dropBody)+                runDiscard :: Int -> ([String], ())+                runDiscard = A.runKleisli (arrowRecDiscardT (A.Kleisli (["unused"],)) (A.Kleisli (\x -> ([show x], ()))))+            expect "feedback also used afterwards" (["copy"], (replicate 2 n, replicate 3 n)) (runCopy n)+            expect "unused output" (["discard"], replicate 3 n) (runDrop n)+            expect "no feedback or used outputs" (["unused", show n], ()) (runDiscard n)+        ]+    , testGroup+        "Star MonadFix"+        [ testProperty "loop and recursive do tie lazy feedback and preserve effect order" $ do+            n <- genNamed @Int "input"+            let before x = (["before"], x + 1)+                body (x, u) = (["body"], (sum (take 3 u), x : u))+                after x = (["after"], x - 2)+                runLoop, runRec :: Int -> ([String], Int)+                runLoop = starLoopT before body after+                runRec = starRecT before body after+                expected = (["before", "body", "after"], 3 * (n + 1) - 2)+            expect "Star loop" expected (runLoop n)+            expect "Star recursive do" expected (runRec n)+        ]+    , testGroup         "FinRel"-        [ testProperty "matrix multiplication is composition (2, 3, 4)" $ do+        [ testProperty "application of a lifted exponential agrees with uncurrying" $ do+            f <- genNamed @((F2 ** F3) ~> F4) "f"+            let curried = Closed.curry @_ @F2 @F3 @F4 f+                actual = toSMC @(F F2 :** F F3) @(F F4) \(x, y) -> (curried -< x) SMC.! y+            expect "apply lifted function" f actual+        , testProperty "arrow application assembles tensor inputs" $ do             f <- genNamed @(F2 ~> F3) "f"             g <- genNamed @(F3 ~> F4) "g"+            let actual = toSMC @(F F2 :** F F3) @(F (F3 ** F4)) \(x, y) ->+                  (f ** g) -< (x, y)+            expect "tensor application" (f ** g) actual+            expect "term application" f (toSMC1 (\x -> f -< x))+            let pipeline = toSMC1 \x -> SMC.do+                  y <- f -< x+                  z <- liftF g y+                  returnA -< z+            expect "inferred intermediate result" (g . f) pipeline+        , testProperty "arrow application binds tensor results" $ do+            f <- genNamed @(F2 ~> (F2 ** F3)) "f"+            g <- genNamed @(F2 ~> F4) "g"+            h <- genNamed @(F3 ~> F2) "h"+            let actual = toSMC1 \z -> SMC.do+                  (x, y) <- f -< z+                  u <- g -< x+                  v <- h -< y+                  returnA -< (u, v)+            expect "process both components" ((g ** h) . f) actual+        , 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"@@ -80,8 +292,15 @@         ]     , testGroup         "Mat Int"-        [ testProperty "matrix multiplication is composition (2, 3, 2)" $ do+        [ testProperty "embedded unit results act as scalars on either side" $ do+            s <- genNamed @((Unit :: MatK Int) ~> Unit) "scalar"             f <- genNamed @(M2 ~> M3) "f"+            let left = toSMC1 \x -> (s -< unit) *^ (f -< x)+                right = toSMC1 \x -> (f -< x) ^* (s -< unit)+            expect "left scalar" (unMat (leftUnitor . (s ** f) . leftUnitorInv)) (unMat left)+            expect "right scalar" (unMat (rightUnitor . (f ** s) . rightUnitorInv)) (unMat right)+        , 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@@ -238,11 +457,12 @@ -- 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+  [ bool+      0+      (sum [product [at dims vs (pick ls) | (ls, dims, vs) <- ins] | rest <- tuples restDims, let pick = assign rest])+      consistent   | o <- tuples (fmap size out)-  , let fixed = M.fromListWith (\a b -> if a == b then a else -1) (zip out o)+  , let fixed = M.fromListWith (\a b -> bool (-1) a (a == b)) (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]   ]
+ test/Props/Simulator.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Props.Simulator (test) where++import Test.Tasty (TestTree, testGroup)+import Prelude++import Proarrow.Category.Instance.Simulator+import Proarrow.Core (CategoryOf (..), UN)+import Proarrow.Testing+  ( Testable (..)+  , TestableProfunctor+  , TestableType (..)+  , TestingEqShow (..)+  , genNamed+  , genSomeDef+  )+import Proarrow.Testing.Laws (testCategory, testCopyDiscard, testMonoidal, testSymMonoidal)+import Props.Hask ()++test :: TestTree+test =+  testGroup+    "Simulator"+    [ testCategory @SIMULATOR+    , testMonoidal @SIMULATOR (\r -> r)+    , testSymMonoidal @SIMULATOR (\r -> r)+    , testCopyDiscard @SIMULATOR (\r -> r)+    ]++instance Testable SIMULATOR where+  type TestOb a = (Ob a, TestOb (UN Sim a))+  obFromTestOb r = r+  showOb @(Sim a) = showOb @_ @a+  genSome = genSomeDef @'[Sim Bool, Sim (), Sim (Bool, Bool)]++instance (TestOb (Sim a), TestOb (Sim b)) => TestableType (Simulator (Sim a) (Sim b)) where+  gen = fromTransition <$> gen @((Bool, a) -> (b, Bool))+    where+      fromTransition transition = go False+        where+          go state = Simulator \x -> let (y, state') = transition (state, x) in (y, go state')++instance (TestOb (Sim a), TestOb (Sim b)) => TestingEqShow (Simulator (Sim a) (Sim b)) where+  showP _ = "<state machine>"+  eqP f g = do+    xs <- genNamed @[a] "clock inputs"+    eqP (runSimulator f xs) (runSimulator g xs)++instance TestableProfunctor Simulator
+ test/Props/Squares.hs view
@@ -0,0 +1,181 @@+module Props.Squares (test) where++import Data.Functor.Compose (Compose (..))+import Data.Kind (Type)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.Falsify (testProperty)+import Prelude++import Proarrow.Category.Instance.Bool (BOOL, Booleans (..))+import Proarrow.Category.Instance.Unit (Unit (..))+import Proarrow.Core ((:~>), type (+->))+import Proarrow.Functor qualified as F+import Proarrow.Limit.BinaryProduct (Product)+import Proarrow.Optic (ExOptic (..), Flip)+import Proarrow.Optic.Getter (GetterFl (..))+import Proarrow.Optic.Lens (LensFl)+import Proarrow.Path (Path (..))+import Proarrow.Profunctor.Corepresentable (Corep (..))+import Proarrow.Profunctor.Instance.Composition ((:.:) (..))+import Proarrow.Profunctor.Instance.Constant (Constant)+import Proarrow.Profunctor.Instance.Identity (Id (..))+import Proarrow.Profunctor.Instance.Star (Star, unStar, pattern Star)+import Proarrow.Profunctor.Instance.Terminal (TerminalProfunctor (..))+import Proarrow.Profunctor.Representable (Rep (..), Representable (..))+import Proarrow.Squares+  ( InputSquare+  , Sq (..)+  , fromTop+  , hArr+  , mkSquare+  , opticSquare+  , proSquare+  , runSquare+  , toBottom+  , vArr+  , (===)+  , (|||)+  )+import Proarrow.Testing (expect, genNamed)+import Props.Hask ()++reverseList :: Star [] :~> Star []+reverseList (Star f) = Star (reverse . f)++dropFirst :: Star [] :~> Star []+dropFirst (Star f) = Star (drop 1 . f)++vertical :: Sq (Star [] ::: Nil) (Star [] ::: Nil) Nil Nil+vertical = vArr reverseList === vArr dropFirst++horizontal :: Sq (Star [] ::: Star [] ::: Nil) (Star [] ::: Star [] ::: Nil) Nil Nil+horizontal = vArr reverseList ||| vArr dropFirst++-- The two nested lists distinguish the first and second legs of the composed path.+input :: [Bool] -> (Star [] :.: Star []) () Bool+input xs = Star (const xs) :.: Star (\n -> [n, not n, False])++type Crossing = Sq (Star [] ::: Nil) (Star [] ::: Nil) (Star Maybe ::: Nil) (Star Maybe ::: Nil)++crossing :: Crossing+crossing = mkSquare (\(Star f) -> Star (traverse f))++-- The constructor exposes arbitrary arrows on both representable legs.+constructorCrossing :: Crossing+constructorCrossing = Sq (\(Star f :.: Star p) -> Star (traverse p . f) :.: Star id)++type NestedCrossing =+  Sq (Star [] ::: Nil) (Star [] ::: Nil) (Star Maybe ::: Star [] ::: Nil) (Star Maybe ::: Star [] ::: Nil)++nestedCrossing :: NestedCrossing+nestedCrossing = mkSquare (\(Star f) -> Star (traverse (traverse f)))++emptySquare :: Sq Nil Nil (Nil :: Path BOOL BOOL) Nil+emptySquare = mkSquare id++type ListEffect = Star (F.Prelude [])+type LensP = Rep (Product Bool)+type LensQ = Corep (Product Bool)++unpackData :: InputSquare LensP (Star ((,) Bool)) (Star [])+unpackData = mkSquare \(Id f) -> Rep (\(flag, a) -> (flag, [f a]))++rebuildData :: InputSquare LensQ (Star Maybe) (Star (Compose ((,) Bool) Maybe))+rebuildData = mkSquare \(Id f) -> Corep (\(flag, a) -> Compose (flag, f <$> a))++mixedInput :: InputSquare ListEffect (Star []) (Star Maybe)+mixedInput = mkSquare (\(Id f) -> Star (\xs -> F.Prelude (Nothing : map (Just . f) xs)))++type BoolShape :: () +-> Type+type BoolShape = Rep (Constant Bool)++identityLeg :: InputSquare Id BoolShape BoolShape+identityLeg = mkSquare \_ -> Id id++forgetLeg :: InputSquare TerminalProfunctor BoolShape BoolShape+forgetLeg = mkSquare (const TerminalProfunctor)++test :: TestTree+test =+  testGroup+    "Squares"+    [ testProperty "vertical composition applies the top square first" $ do+        xs <- genNamed @[Bool] "xs"+        case vertical of+          Sq n -> expect "bottom after top" (drop 1 (reverse xs)) (unStar (n (Star (const xs))) ())+    , testProperty "horizontal composition reads path legs right to left" $ do+        xs <- genNamed @[Bool] "xs"+        case horizontal of+          Sq n ->+            expect "left acts on the outer list" (reverse (map (\x -> [not x, False]) xs)) (index (n (input xs)) ())+    , testProperty "vertical composition of representable paths reads top to bottom" $ do+        xs <- genNamed @[Bool] "xs"+        case hArr reverseList === hArr dropFirst of+          Sq n ->+            expect+              "top acts on the inner list"+              (map (reverse . (\x -> [x, not x, False])) (drop 1 xs))+              (index (n (input xs)) ())+    , testProperty "horizontal companion bends recover the vertical identity" $ do+        xs <- genNamed @[Bool] "xs"+        case fromTop @(Star []) ||| toBottom @(Star []) of+          Sq n -> expect "straightened companion" xs (unStar (n (Star (const xs))) ())+    , testProperty "pointwise traversal agrees with traverse and the constructor" $ do+        xs <- genNamed @[Bool] "xs"+        let f b = b : xs+            values = [Nothing, Just False, Just True]+            run sq = map (unStar (runSquare sq (Star f))) values+        expect "traverse" (map (traverse f) values) (run crossing)+        expect "constructor" (run constructorCrossing) (run crossing)+    , testProperty "mkSquare . runSquare preserves the constructor payload" $ do+        xs <- genNamed @[Bool] "xs"+        let rebuilt :: Crossing+            rebuilt = mkSquare (runSquare constructorCrossing)+            values = [Nothing, Just False, Just True]+            payload :: (Star Maybe :.: Star []) (Maybe Bool) Bool+            payload = Star (fmap not) :.: Star (: xs)+        case (constructorCrossing, rebuilt) of+          (Sq original, Sq restored) ->+            expect "arbitrary representable input" (map (index (original payload)) values) (map (index (restored payload)) values)+    , testProperty "pointwise conversion handles composed representable paths" $ do+        xs <- genNamed @[Bool] "xs"+        let f b = b : xs+            values = [[], [Nothing], map Just xs, [Just False, Nothing, Just True]]+        expect+          "nested traversal"+          (map (traverse (traverse f)) values)+          (map (unStar (runSquare nestedCrossing (Star f))) values)+    , testProperty "pointwise conversion handles composed profunctor paths" $ do+        xs <- genNamed @[Bool] "xs"+        let n = index (runSquare (crossing ||| crossing) (input xs))+        expect "no data" [[Nothing]] (n Nothing)+        expect "data" (map (map Just . (\x -> [x, not x, False])) xs) (n (Just ()))+    , testProperty "pointwise conversion handles empty paths in a non-Hask category" $+        case runSquare emptySquare (Id F2T) of+          Id f -> expect "identity" F2T f+    , testProperty "proSquare absorbs a residual pair around the effect" $ do+        xs <- genNamed @[Bool] "xs"+        flag <- genNamed @Bool "flag"+        let lensCrossing = proSquare @LensFl @ListEffect @LensP @LensQ+            effect = Star (\b -> F.Prelude (b : xs))+            run = F.unPrelude . unStar (runSquare lensCrossing (Rep id :.: effect :.: Corep id))+        expect "residual" (map (flag,) (True : xs)) (run (flag, True))+    , testProperty "opticSquare composes different read and write shapes" $ do+        flag <- genNamed @Bool "flag"+        value <- genNamed @Bool "value"+        let program = opticSquare @LensFl @ListEffect @LensP @LensQ unpackData rebuildData mixedInput+            run = map getCompose . F.unPrelude . unStar (runSquare program (Id not))+        expect "mixed optic" [(flag, Nothing), (flag, Just (not value))] (run (flag, value))+    , testProperty "opticSquare accepts a right witness without corepresentability" $+        let focus :: InputSquare (ExOptic GetterFl Bool Bool) BoolShape BoolShape+            focus = mkSquare (\(Id Unit) -> ExOptic (Id not) (Id id))+            program = opticSquare @GetterFl identityLeg forgetLeg focus+        in case runSquare program (Id Unit) of+             ExOptic @p @q left _ -> expect "getter" False (getP @p @q left True)+    , testProperty "opticSquare accepts a left witness without representability" $+        let focus :: InputSquare (ExOptic (Flip GetterFl) Bool Bool) BoolShape BoolShape+            focus = mkSquare (\(Id Unit) -> ExOptic (Id id) (Id not))+            program = opticSquare @(Flip GetterFl) forgetLeg identityLeg focus+        in case runSquare program (Id Unit) of+             ExOptic @p @q _ right -> expect "review" True (getP @q @p right False)+    ]
test/Props/Svg.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | The SVG diagrams mean what the Dot diagrams they carry mean, so their laws are checked with
test/Props/TensorNetwork.hs view
@@ -1,10 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE OverloadedLists #-} {-# OPTIONS_GHC -Wno-orphans #-}  -- | Tensor networks with integer entries, compared by their entries. module Props.TensorNetwork (test) where -import Data.Complex (Complex (..))+import Data.Complex (Complex (..), conjugate)+import Data.List (transpose) import Data.Vector.Storable qualified as SV import GHC.TypeNats (KnownNat) import Test.Falsify (Property)@@ -78,11 +80,20 @@         , 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)))))+        , testProperty "the dagger of complex entries is the conjugate transpose" do+            f <- complexArrow @'[2] @'[3]+            expect "entries" (conjugateTranspose (entries f)) (entries (dagger f))+        , testProperty "the complex dagger reverses composition" do+            f <- complexArrow @'[2] @'[3]+            g <- complexArrow @'[3] @'[2]+            expect "entries" (entries (dagger f . dagger g)) (entries (dagger (g . f)))+        , testProperty "a complex dagger composed with entries that are not conjugated" do+            f <- complexArrow @'[2] @'[3]+            g <- complexArrow @'[2] @'[3]+            expect "entries" (entries (fromEntries @'[3] @'[2] (conjugateTranspose (entries f)) . g)) (entries (dagger f . g))+        , testProperty "two complex daggers cancel" do+            f <- complexArrow @'[2] @'[3]+            expect "entries" (entries f) (entries (dagger (dagger f)))         ]     , testGroup         "einsum"@@ -112,6 +123,20 @@   where     -- a product of all four would have 32^8 entries; each pairwise contraction costs about 32^3     fewer = defaultTestOptions{overrideNumTests = Just 5}++-- | An arrow with complex entries, whose real and imaginary parts are small integers.+complexArrow+  :: forall as bs+   . (KnownListOf KnownNat as, KnownListOf KnownNat bs)+  => Property (TensorNetwork (TN as :: TNET (Complex Double)) (TN bs))+complexArrow = do+  re <- genNamed @(TN as ~> (TN bs :: TNET Int)) "re"+  im <- genNamed @(TN as ~> (TN bs :: TNET Int)) "im"+  pure (fromVector (SV.zipWith (\x y -> fromIntegral x :+ fromIntegral y) (toVector re) (toVector im)))++-- | The conjugate transpose of rows of entries.+conjugateTranspose :: [[Complex Double]] -> [[Complex Double]]+conjugateTranspose = map (map conjugate) . transpose  -- | The same arrow with its entries as 'Double's, which are contracted with 'gemm' where there is -- one.
testing/Proarrow/Testing.hs view
@@ -126,7 +126,7 @@ 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.Corepresentable (Corep (..), type (%%)) import Proarrow.Profunctor.Instance.Coproduct ((:+:) (..)) import Proarrow.Profunctor.Instance.Costar (Costar, pattern Costar) import Proarrow.Profunctor.Instance.Exponential ((:~>:) (..))@@ -597,6 +597,12 @@ instance (TestingEqShow (a ~> (f Rep.@ b)), Ob b) => TestingEqShow (Rep f a b) where   eqP (Rep l) (Rep r) = eqP l r   showP (Rep p) = showP p++instance (TestableType ((f Rep.@ a) ~> b), Ob a) => TestableType (Corep f a b) where+  gen = invmap Corep unCorep (gen @(f Rep.@ a ~> b))+instance (TestingEqShow ((f Rep.@ a) ~> b), Ob a) => TestingEqShow (Corep f a b) where+  eqP (Corep l) (Corep r) = eqP l r+  showP (Corep p) = showP p  instance (TestingEqShow (catk a1 b1), TestingEqShow (catj a2 b2)) => TestingEqShow ((catk :**: catj) '(a1, a2) '(b1, b2)) where   eqP (l1 :**: l2) (r1 :**: r2) = liftA2 (&&) (eqP l1 r1) (eqP l2 r2)
+ tools/haddock/interfaces.py view
@@ -0,0 +1,74 @@+#!/usr/bin/env python3+"""Collect library interfaces and check the combined Haddock index."""++import argparse+import json+from html.parser import HTMLParser+from pathlib import Path+import shutil+import sys+++def collect(package, builddir):+    package = package.resolve()+    project = next((p for p in (package, *package.parents) if (p / 'cabal.project').is_file()), None)+    if project is None:+        raise ValueError('No cabal.project found above the package directory')+    plan = json.loads((project / builddir / 'cache/plan.json').read_text())+    for component, relative in (+        ('lib', 'doc/html/proarrow/proarrow.haddock'),+        ('lib:testing', 'doc/html/proarrow/testing/testing.haddock'),+    ):+        entries = [entry for entry in plan['install-plan']+                   if entry.get('pkg-name') == 'proarrow'+                   and entry.get('component-name') == component+                   and Path(entry.get('pkg-src', {}).get('path', '')).resolve() == package]+        if len(entries) != 1:+            raise ValueError(f'Expected one local proarrow {component} in the build plan, found {len(entries)}')+        source = Path(entries[0]['dist-dir']) / relative+        shutil.copyfile(source, package / 'docs' / source.name)+++def check_index(index):+    class Captions(HTMLParser):+        def __init__(self):+            super().__init__()+            self.current = None+            self.packages = set()++        def handle_starttag(self, tag, attrs):+            if tag == 'p' and 'caption' in dict(attrs).get('class', '').split():+                self.current = []++        def handle_data(self, data):+            if self.current is not None:+                self.current.append(data)++        def handle_endtag(self, tag):+            if tag == 'p' and self.current is not None:+                self.packages.add(''.join(self.current).strip().rsplit('-', 1)[0])+                self.current = None++    captions = Captions()+    captions.feed(index.read_text())+    missing = {'proarrow', 'proarrow:testing'} - captions.packages+    if missing:+        raise ValueError(f'{index} does not list packages: {", ".join(sorted(missing))}')+++def main():+    parser = argparse.ArgumentParser(description=__doc__)+    parser.add_argument('--check-index', action='store_true')+    parser.add_argument('--builddir', type=Path, default=Path('dist-newstyle'))+    args, _ = parser.parse_known_args()+    try:+        if args.check_index:+            check_index(Path('docs/index.html'))+        else:+            collect(Path.cwd().resolve(), args.builddir)+    except (OSError, ValueError, KeyError) as error:+        sys.exit(f'Haddock documentation: {error}')+++if __name__ == '__main__':+    main()
+ tools/haddock/test_interfaces.py view
@@ -0,0 +1,82 @@+"""Regression checks for interface collection in checkout and unpacked CI layouts."""++import json+from pathlib import Path+import tempfile+import unittest++from interfaces import check_index, collect+++class InterfacesTest(unittest.TestCase):+    def setUp(self):+        self.temp = tempfile.TemporaryDirectory()+        self.addCleanup(self.temp.cleanup)+        self.project = Path(self.temp.name)+        (self.project / 'cabal.project').write_text('packages: unpacked/proarrow-0.3.0.0\n')++    def prepare(self, location, builddir='dist-newstyle'):+        package = self.project / location+        (package / 'docs').mkdir(parents=True)+        entries = []+        for component, subdir, relative, contents in (+            ('lib', '', 'doc/html/proarrow/proarrow.haddock', b'main interface'),+            ('lib:testing', 'l/testing', 'doc/html/proarrow/testing/testing.haddock', b'testing interface'),+        ):+            dist = self.project / builddir / 'build/platform/compiler/proarrow-0.3.0.0' / subdir+            interface = dist / relative+            interface.parent.mkdir(parents=True)+            interface.write_bytes(contents)+            entries.append({'pkg-name': 'proarrow', 'component-name': component,+                            'pkg-src': {'path': str(package)}, 'dist-dir': str(dist)})+        cache = self.project / builddir / 'cache'+        cache.mkdir()+        (cache / 'plan.json').write_text(json.dumps({'install-plan': entries}))+        return package++    def assert_interfaces(self, package):+        self.assertEqual((package / 'docs/proarrow.haddock').read_bytes(), b'main interface')+        self.assertEqual((package / 'docs/testing.haddock').read_bytes(), b'testing interface')++    def test_checkout(self):+        package = self.prepare('proarrow')+        collect(package, Path('dist-newstyle'))+        self.assert_interfaces(package)++    def test_unpacked_ci(self):+        package = self.prepare('unpacked/proarrow-0.3.0.0')+        self.assertFalse((package.parent / 'dist-newstyle').exists())+        collect(package, Path('dist-newstyle'))+        self.assert_interfaces(package)++    def test_custom_builddir_ignores_stale_interfaces(self):+        package = self.prepare('proarrow', 'dist-9103')+        stale = self.project / 'dist-newstyle/build/old'+        stale.mkdir(parents=True)+        (stale / 'proarrow.haddock').write_bytes(b'stale interface from another compiler')+        collect(package, Path('dist-9103'))+        self.assert_interfaces(package)++    def test_missing_interface_fails(self):+        package = self.prepare('unpacked/proarrow-0.3.0.0')+        next((self.project / 'dist-newstyle/build').rglob('testing.haddock')).unlink()+        with self.assertRaises(FileNotFoundError):+            collect(package, Path('dist-newstyle'))++    def test_combined_index(self):+        index = self.project / 'index.html'+        index.write_text('<p class="caption">proarrow-0.3.0.0</p>'+                         '<p class="caption">proarrow:testing-0.3.0.0</p>')+        check_index(index)++    def test_testing_only_index_fails_even_with_main_library_links(self):+        index = self.project / 'index.html'+        index.write_text('<p class="caption">proarrow:testing-0.3.0.0</p>'+                         '<a href="Proarrow.html">Start here</a>'+                         '<a href="Proarrow-Core.html">Core</a>')+        with self.assertRaises(ValueError):+            check_index(index)+++if __name__ == '__main__':+    unittest.main()
+ tools/optic-diagrams/README.md view
@@ -0,0 +1,37 @@+# Optic composition by graph substitution++Render the example and a comparison page from the repository root:++```sh+python3 proarrow/tools/optic-diagrams/render.py /tmp/proarrow-optic-diagrams+```++Open `/tmp/proarrow-optic-diagrams/index.html`. The SVG files can also be viewed separately.+The diagrams come from the tested example in `test/Examples/OpticDiagrams.hs`.++The source is `g . f`. `substituteWith` expands each wire to a forward/backward pair and each+box to two legs connected by a residual. Paired boundaries connect both directions when the+encoded diagrams compose. Moving the external backward wires produces a computation from+`(a⁺, c⁻)` to `(c⁺, a⁻)`: the forward legs run `f`, then `g`, and the backward legs run `g`,+then `f`, using their own residuals. This follows §10 of Wilson and Zanasi,+[Data-Parallel Algorithms for String Diagrams](https://arxiv.org/abs/2305.01041).++The tests compare the substituted graph with an independently assembled graph and an SMC+program. The SVGs are rendered from the substituted graph through `readBack`.++The second example gives the primitives their reverse-derivative meaning for `sin(x²)`.+The square's forward leg produces `(x², x)` and the sine's produces `(sin z, cos z)`.+Their backward legs multiply the cotangent by `cos z` and then by `2x`.+The generated graph shares these residuals, with each primitive present once.++The same SMC schedule runs numerically in a writer that records primitive calls. Tests check+the chain rule, finite differences, and the existing `DIFF` implementation. The numerical computation now comes from an SMC source program in `Proarrow.Tools.Optic.OPTICS`,+with its primitives supplied by `opticLegs`. `runOptics` expands those primitives by graph+substitution, moves the backward boundaries and reads the result back with `permutations`.+The target needs only symmetric monoidal structure. Both computations are checked against+the same references.++The same module also tests parallel programs, mixed forward/backward types,+existing optic encodings, empty boundaries and multi-output primitives bound with SMC tuple+patterns. An explicit duplication optic copies a value on the forward pass and adds cotangents+on the backward pass. A writer backend checks that the compiled graph executes every leg once.
+ tools/optic-diagrams/render.py view
@@ -0,0 +1,38 @@+#!/usr/bin/env python3+"""Render the tested optic-composition example: render.py OUTPUT_DIRECTORY."""++from pathlib import Path+from shutil import copyfile+import sys++sys.path.insert(0, str(Path(__file__).resolve().parents[1] / 'law-gallery'))+from gallery import hs_string, run_repl, standalone  # noqa: E402+++def main():+    if len(sys.argv) != 2:+        sys.exit(__doc__)+    destination = Path(sys.argv[1]).resolve()+    destination.mkdir(parents=True, exist_ok=True)+    pictures = [+        ('source', 'sourcePicture', False),+        ('encoded', 'encodedPicture', True),+        ('composition', 'compositionPicture', True),+        ('derivative-source', 'derivativeSourcePicture', False),+        ('derivative', 'derivativePicture', True),+    ]+    script = [':m + *Examples.OpticDiagrams']+    for name, function, checked in pictures:+        writer = f'writeFile {hs_string(str(destination / (name + ".svg")))}'+        expression = f'Examples.OpticDiagrams.{function}'+        script.append(f'either fail ({writer}) {expression}' if checked else f'{writer} {expression}')+    run_repl('test:test', script)+    for name, _, _ in pictures:+        path = destination / (name + '.svg')+        path.write_text(standalone(path.read_text(encoding='utf-8')), encoding='utf-8')+    copyfile(Path(__file__).with_name('template.html'), destination / 'index.html')+    print(f'Written to {destination / "index.html"}')+++if __name__ == '__main__':+    main()
+ tools/optic-diagrams/template.html view
@@ -0,0 +1,37 @@+<!doctype html>+<html lang="en"><meta charset="utf-8"><title>Optic composition by graph substitution</title>+<style>+body{font:16px system-ui,sans-serif;margin:32px;color:#1f2328;background:#fff}+main{display:flex;gap:40px;align-items:flex-start;flex-wrap:wrap}+figure{margin:0}figcaption{font-weight:600;margin-bottom:16px}img{max-width:100%;height:auto}+p{max-width:850px;line-height:1.5}+@media(prefers-color-scheme:dark){body{color:#e6edf3;background:#0d1117}}+</style>+<h1>Optic composition by graph substitution</h1>+<p>Each source wire expands to a forward (+) and backward (−) wire. Each generator expands+into a forward box and a backward box, connected by a residual m_f or m_g.+The forward pass runs f then g; the backward pass runs g then f.</p>+<p>The encoding composes with paired boundaries. Moving the external backward wires gives+inputs (a+, c−) and outputs (c+, a−). Residuals connect the two passes without recomputing them.</p>+<main>+<figure><figcaption>Source: g ∘ f</figcaption><img src="source.svg" alt="Two source boxes"></figure>+<figure><figcaption>Paired boundaries</figcaption><img src="encoded.svg" alt="Encoded optics with paired boundaries"></figure>+<figure><figcaption>Forward and backward computation</figcaption><img src="composition.svg" alt="Composed forward and backward passes"></figure>+</main>+<h2>Reverse derivative of sin(x²)</h2>+<p>Here a⁺ is x, b⁺ is z = x² and c⁺ is y = sin z. The reverse pass receives a seed dy+on c⁻ and returns dx = 2x cos(x²) dy on a⁻. The square saves x on m_f; the sine saves+cos z on m_g. Each forward box occurs once and the backward boxes use these saved values.</p>+<main>+<figure><figcaption>Source function</figcaption><img src="derivative-source.svg" alt="Square followed by sine"></figure>+<figure><figcaption>Value and reverse derivative</figcaption><img src="derivative.svg" alt="Square and sine forward, then their reverse derivatives using saved values"></figure>+</main>+<p>The matching SMC program is tested numerically against the chain rule, finite differences,+and Proarrow.Category.Instance.Diff. A writer records exactly one call to each primitive,+in forward-then-backward order. The translated graph also executes directly as a Haskell function through the symmetric+monoidal read-back; its numerical results agree with the SMC schedule. The SVG uses the+hypergraph read-back.</p>+<p>Generated from Examples.OpticDiagrams. Tests compare the substituted graph with a hand-built+composite and an SMC program. Construction follows §10 of+<a href="https://arxiv.org/abs/2305.01041">Wilson and Zanasi, Data-Parallel Algorithms for String Diagrams</a>.</p>+</html>
+ tools/smc-audio/Main.hs view
@@ -0,0 +1,27 @@+module Main where++import Control.Arrow ((>>>))+import Data.WAVE (WAVE (..), WAVEHeader (..), doubleToSample, putWAVEFile)+import System.Directory (createDirectoryIfMissing)+import System.Environment (getArgs)+import System.FilePath ((</>))+import Prelude++import SmcAudio (echo, echoPicture, melody, sampleRate, samples)++main :: IO ()+main = do+  args <- getArgs+  case args of+    [dir] -> do+      createDirectoryIfMissing True dir+      writeAudio (dir </> "dry.wav") (samples melody)+      writeAudio (dir </> "echo.wav") (samples (melody >>> echo 0.3 0.5))+      writeFile (dir </> "echo.svg") echoPicture+      putStrLn ("Wrote dry.wav, echo.wav and echo.svg to " ++ dir)+    _ -> ioError (userError "Usage: cabal run smc-audio -- OUTPUT_DIRECTORY")++writeAudio :: FilePath -> [Double] -> IO ()+writeAudio file xs = putWAVEFile file (WAVE header (map (\x -> [doubleToSample (max (-1) (min 1 x))]) xs))+  where+    header = WAVEHeader{waveNumChannels = 1, waveFrameRate = sampleRate, waveBitsPerSample = 16, waveFrames = Nothing}
+ tools/smc-audio/README.md view
@@ -0,0 +1,44 @@+# Hear an SMC program++From the repository root:++```sh+cabal run smc-audio -- /tmp/proarrow-audio+```++Play `dry.wav`, then `echo.wav`. Both contain the same short arpeggio; the second adds+repeating echoes. `echo.svg` draws the network that produces them.++The program is the feedback connection itself:++```haskell+echoWith mix delay = proc @(F a) @(F a) \input -> SMC.do+  rec output <- mix -< (input, delay -< output)+  returnA -< output+```++`mix` adds the input to half of the delayed output. `delay` stores 0.3 seconds of audio,+initially filled with silence. An output returns as an echo after 0.3 seconds, then again+after 0.6 seconds at half that amplitude, and so on. The positive delay lets the network+produce a sample before it needs that sample back.++The variables are wires. Using `output` in the feedback connection and as the result copies+it, while `rec` closes the loop. The source does not manage a buffer, shuffle a tuple or call+an arrow combinator.++`echoWith` is interpreted twice: `Arr SF` uses Yampa to process audio, and `Svg` draws the+mixer, delay and feedback wire. The implementation is shared; only the supplied boxes change.+Yampa is wrapped with `Arr`, which supplies SMC's promonad and feedback instances from+`Arrow` and `ArrowLoop`.++The executable samples five seconds at 44,100 Hz and writes mono, 16-bit PCM WAV files using+`WAVE`. Rendering is offline and needs no sound-device bindings. Yampa is a dependency of+the example and its tests; WAVE is used only by the executable. Neither is a dependency of+the main proarrow library.++The tests check an impulse's echoes against their expected amplitudes and spacing, and check+one-sample feedback against the recurrence `output[n] = input[n] + 0.5 * output[n-1]`.++The GitHub Pages documentation build also renders these files into `docs/audio/`, so the+wiki can link to [dry.wav](https://sjoerdvisscher.github.io/proarrow/audio/dry.wav) and+[echo.wav](https://sjoerdvisscher.github.io/proarrow/audio/echo.wav).
+ tools/smc-audio/SmcAudio.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE QualifiedDo #-}+{-# LANGUAGE RecursiveDo #-}++-- | A feedback echo, interpreted as a Yampa signal function or a string diagram.+module SmcAudio (echoWith, echo, melody, sampleRate, duration, samples, echoPicture) where++import Control.Arrow qualified as A+import FRP.Yampa qualified as Y+import Prelude hiding ((.))++import Proarrow.Category.Monoidal (Monoidal (..), MonoidalProfunctor, SymMonoidal, Tensor)+import Proarrow.Category.Monoidal.Strength (Costrong)+import Proarrow.Core (CAT, Promonad)+import Proarrow.Monoid (CocommutativeComonoid)+import Proarrow.Profunctor.Instance.Arrow (Arr (..))+import Proarrow.Tools.Diagrams.Svg (SVG (..), W (Wire), node, render)+import Proarrow.Tools.SMC (SYN (..), proc, returnA, (-<))+import Proarrow.Tools.SMC qualified as SMC++-- | Mix the input with a delayed copy of the output. The delay must break the instantaneous+-- feedback dependency. Copying the output sends it both to the delay and to the caller.+{-# INLINE echoWith #-}+echoWith+  :: forall {k} (a :: k) (p :: CAT k)+   . (SymMonoidal k, Promonad p, MonoidalProfunctor p, Costrong Tensor p, CocommutativeComonoid a)+  => p (a ** a) a+  -> p a a+  -> p a a+echoWith mix delay = proc @(F a) @(F a) \input -> SMC.do+  rec output <- mix -< (input, delay -< output)+  returnA -< output++-- | Echoes repeat every @seconds@, each scaled by @gain@. Use a positive delay and+-- @abs gain < 1@ for a decaying echo.+echo :: Double -> Double -> Y.SF Double Double+echo seconds gain = unArr (echoWith (Arr (A.arr (\(dry, wet) -> dry + gain * wet))) (Arr (Y.delay seconds 0)))++-- | A short arpeggio with a decaying envelope on each note, followed by silence for the echo tail.+melody :: Y.SF () Double+melody = Y.time A.>>> A.arr tone+  where+    tone t+      | t >= 2 = 0+      | otherwise =+          let note = floor (t / 0.25) :: Int+              age = t - fromIntegral note * 0.25+              frequency = [261.6256, 329.6276, 391.9954, 523.2511, 391.9954, 329.6276, 261.6256, 523.2511] !! note+              envelope = (1 - exp (-(200 * age))) * exp (-(16 * age))+          in 0.3 * envelope * sin (2 * pi * frequency * age)++sampleRate :: Int+sampleRate = 44100++duration :: Double+duration = 5++-- | Sample a closed signal function at the audio rate for the demo's duration.+samples :: Y.SF () Double -> [Double]+samples sf = take (round (duration * fromIntegral sampleRate)) (Y.embed sf ((), repeat (1 / fromIntegral sampleRate, Nothing)))++-- | The feedback network drawn with its mixer and delay as boxes.+echoPicture :: String+echoPicture = render (echoWith @(S '[Wire "audio"]) (node "mix: dry + 0.5 wet") (node "delay: 0.3 s"))