Diagramv2

stbx-lang/package.json

@@ -14,6 +14,7 @@
     "postinstall": "spago install",
     "start": "spago run",
     "build": "spago build",
+    "watch": "spago build --watch",
     "test": "spago test"
   },
   "license": "ISC",

stbx-lang/spago.dhall

@@ -5,6 +5,7 @@
     , "debug"
     , "effect"
     , "halogen-petrinet-editor"
+    , "memoize"
     , "parsing"
     , "psci-support"
     , "spec"
@@ -15,4 +16,4 @@
     ./../packages.dhall
 , sources =
     [ "src/**/*.purs", "test/**/*.purs" ]
-}
+}

stbx-lang/src/Language/Statebox.purs

@@ -11,7 +11,7 @@ import Language.Statebox.Wiring.AST (GElem(..)) as Wiring
 import Language.Statebox.Wiring.Parser as WiringParser
 
 parseNet :: String -> Either ParseError (List Net.GElem)
-parseNet src = runParser src NetParser.graph1
+parseNet src = runParser src NetParser.net
 
-parseWiring :: String -> Either ParseError (List Wiring.GElem)
-parseWiring src = runParser src WiringParser.graph1
+parseDiagram :: String -> Either ParseError (List Wiring.GElem)
+parseDiagram src = runParser src WiringParser.diagram

stbx-lang/src/Language/Statebox/Net/Parser.purs

@@ -18,8 +18,8 @@ import Language.Statebox.Hypergraph (NodeF(..), HyperEdgeF(..), GElemF(..))
 import Language.Statebox.Net.AST (Node(..), HyperEdge(..), LabelWithSpan, LabelWithSpanWithType, GElem(..))
 import Language.Statebox.Parser.Util (getPosition, hspaces, inside, isAlphaNum, someOf)
 
-graph1 :: Parser String (List GElem)
-graph1 = (gElem `inside` hspaces) `sepEndBy` (semicolon <|> newlines)
+net :: Parser String (List GElem)
+net = (gElem `inside` hspaces) `sepEndBy` (semicolon <|> newlines)
   where
     newlines = skipMany1 (char '\n')
     semicolon = const unit <$> char ';'

stbx-lang/src/Language/Statebox/Wiring/Generator.purs

@@ -0,0 +1,36 @@
+module Language.Statebox.Wiring.Generator where
+
+import Prelude
+import Data.Array (length, elemIndex)
+import Data.Maybe (maybe)
+import Data.Foldable (foldMap)
+import Data.Bitraversable (bitraverse)
+import Data.List (List)
+import Data.Traversable (traverse)
+import Data.Traversable.Accum.Internal (StateL(..), stateL)
+
+import Language.Statebox.Hypergraph (HyperEdgeF(..), GElemF(..))
+import Language.Statebox.Wiring.AST (GElem, stripSpan)
+
+
+toIndexedGraph :: List GElem -> { graph :: List (GElemF List Int Unit), names :: Array String }
+toIndexedGraph ast = { graph: acc.value, names: acc.accum }
+  where
+    acc = traverse (bitraverse (stripSpan >>> lookupOrAdd) idStateL) ast # (_ `stateL` [])
+
+lookupOrAdd :: ∀ v. Eq v => v -> StateL (Array v) Int
+lookupOrAdd v =
+  StateL $ \vs -> elemIndex v vs # maybe { accum: vs <> [v], value: length vs + 1 }
+                                          \i -> { accum: vs, value: i + 1 }
+
+idStateL :: ∀ a s. a -> StateL s a
+idStateL value = StateL $ \accum -> { accum, value }
+
+
+type Edges a = Array { src :: a, tgt :: a }
+
+getEdges :: ∀ a. List (GElemF List a Unit) -> Edges a
+getEdges = foldMap f
+  where
+    f (GHyperEdge (HyperEdge _ srcs tgts)) = foldMap (\src -> foldMap (\tgt -> [{ src, tgt }]) tgts) srcs
+    f _                                    = []

stbx-lang/src/Language/Statebox/Wiring/Generator/Diagram.purs

@@ -1,33 +1,18 @@
 module Language.Statebox.Wiring.Generator.Diagram where
 
 import Prelude
-import Data.Array (length, elemIndex)
-import Data.Maybe (maybe)
-import Data.Foldable (foldMap)
-import Data.Bitraversable (bitraverse)
-import Data.Traversable (traverse)
-import Data.Traversable.Accum.Internal (StateL(..), stateL)
+import Data.Array (length)
 import Data.List (List)
 
-import Language.Statebox.Hypergraph (HyperEdgeF(..), GElemF(..))
-import Language.Statebox.Wiring.AST (GElem, stripSpan)
+import Language.Statebox.Wiring.Generator (toIndexedGraph, getEdges)
+import Language.Statebox.Wiring.AST (GElem)
 import Statebox.Core.Types (Diagram)
 
 toDiagramWithName :: String -> List GElem -> Diagram
 toDiagramWithName name ast =
-  { name, width, pixels, names: acc.accum }
+  { name, width, pixels, names }
   where
-    acc = traverse (bitraverse (stripSpan >>> lookupOrAdd) idStateL) ast # (_ `stateL` [])
-    getEdges (GHyperEdge (HyperEdge _ srcs targs)) = foldMap (\src -> foldMap (\targ -> [{ src, targ }]) targs) srcs
-    getEdges _                                     = []
-    edges = foldMap getEdges acc.value
+    { graph, names } = toIndexedGraph ast
+    edges = getEdges graph
     width = length edges
-    pixels = (edges <#> _.src) <> (edges <#> _.targ)
-
-lookupOrAdd :: ∀ v. Eq v => v -> StateL (Array v) Int
-lookupOrAdd v =
-  StateL $ \vs -> elemIndex v vs # maybe { accum: vs <> [v], value: length vs + 1 }
-                                         \i -> { accum: vs, value: i + 1 }
-
-idStateL :: ∀ a s. a -> StateL s a
-idStateL value = StateL $ \accum -> { accum, value }
+    pixels = (edges <#> _.src) <> (edges <#> _.tgt)

stbx-lang/src/Language/Statebox/Wiring/Generator/DiagramV2.purs

@@ -0,0 +1,124 @@
+module Language.Statebox.Wiring.Generator.DiagramV2 where
+
+import Prelude
+import Data.Array (zipWith, take, drop, concat, length, (..), (!!), uncons, elemIndex, filter)
+import Data.Char (fromCharCode, toCharCode)
+import Data.Foldable (class Foldable, maximum, intercalate, foldMap, fold, notElem)
+import Data.FoldableWithIndex (foldMapWithIndex)
+import Data.FunctorWithIndex (mapWithIndex)
+import Data.List (List)
+import Data.Map (Map, fromFoldableWith, lookup, union, toUnfoldable)
+import Data.Map.Internal (keys)
+import Data.Maybe (maybe, fromMaybe)
+import Data.String.CodeUnits (singleton)
+import Data.TraversableWithIndex (mapAccumLWithIndex)
+import Data.Tuple (snd)
+import Data.Tuple.Nested ((/\), type (/\))
+import Data.Function.Memoize (memoize, class Tabulate)
+import Statebox.Core.Types (Diagram)
+
+import Language.Statebox.Wiring.Generator (Edges, toIndexedGraph, getEdges)
+import Language.Statebox.Wiring.AST (GElem)
+
+-- | A kdmoncat-compatible diagram in source code representation.
+type DiagramV2 =
+  { pixels  :: String
+  , context :: String
+  }
+
+fromDiagramAst :: List GElem -> DiagramV2
+fromDiagramAst ast = fromEdges (_ - 1) name edges
+  where
+    { graph, names } = toIndexedGraph ast
+    edges = getEdges graph
+    name id = names !! (id - 1) # fromMaybe "?"
+
+fromDiagram :: Diagram -> DiagramV2
+fromDiagram { width, pixels, names } = fromEdges (_ - 1) name edges
+  where
+    rows = chunks width pixels
+    edges = concat $ zipWith (zipWith (\src tgt -> { src, tgt })) rows (drop 1 rows)
+    name id = names !! (id - 1) # fromMaybe "?"
+
+fromEdges :: ∀ a. Ord a => Tabulate a => (a -> Int) -> (a -> String) -> Edges a -> DiagramV2
+fromEdges fromEnum name edges = { pixels, context }
+  where
+    pixels = (0 .. height) <#> row # intercalate "\n"
+    context = [nodeTypes, swapTypes] # intercalate "\n"
+
+    predecessors :: Map a (Array a)
+    predecessors = edges <#> (\{ src, tgt } -> tgt /\ [src]) # mfromFoldable
+
+    successors :: Map a (Array a)
+    successors = edges <#> (\{ src, tgt } -> src /\ [tgt]) # mfromFoldable
+
+    inputs :: Map a (Array Int)
+    inputs = edges # mapWithIndex (\i { tgt } -> tgt /\ [i]) # mfromFoldable
+
+    outputs :: Map a (Array Int)
+    outputs = edges # mapWithIndex (\i { src } -> src /\ [i]) # mfromFoldable
+
+    level :: a -> Int
+    level = memoize \a -> mlookup a predecessors <#> level # maximum # maybe 0 (_ + 1)
+
+    nodes :: List a
+    nodes = (successors `union` predecessors) # keys
+
+    grouped :: Array (Array a)
+    grouped = nodes <#> (\id -> level id /\ [id]) # mfromFoldable # toUnfoldable <#> snd
+
+    width = length grouped
+    height = grouped <#> length # maximum # fromMaybe 0
+
+    typeStr :: a -> Map a (Array a) -> (a -> String) -> String
+    typeStr a m f = mlookup a m <#> f # intercalate " "
+
+    pixel :: a -> String
+    pixel a = nextChar 'A' (fromEnum a)
+
+    nodeType :: a -> String
+    nodeType a = name a <> "@" <> pixel a <> ": " <> typeStr a predecessors (\b -> name b <> "_" <> name a)
+                                        <> " -> " <> typeStr a successors   (\b -> name a <> "_" <> name b)
+    nodeTypes :: String
+    nodeTypes = map nodeType nodes # intercalate "\n"
+
+    row :: Int -> String
+    row y = grouped # foldMapWithIndex \x g ->
+      ((g !! y) # maybe (if x > 0 && x < width - 1 then nextChar 'n' (x - 1) else " ") pixel) <>
+      if x < width - 1 then nextChar 'a' x else ""
+
+    swapTypes :: String
+    swapTypes = grouped
+              # uncons
+             <#> (\{ head, tail } -> mapAccumLWithIndex mkSwap (levelOutputs head) tail)
+              # maybe "" (_.value >>> intercalate "\n")
+
+    mkSwap :: Int -> Array Int -> Array a -> { accum :: Array Int, value :: String }
+    mkSwap i edgeIds as = { accum: levelOutputs as <> rest, value }
+      where
+        value = nextChar 'a' i <> ": [" <> intercalate " " order <> "]\n" <>
+                nextChar 'n' i <> ": [" <> intercalate " " ((1 ..< (length rest + 1)) <#> show) <> "]"
+        ids = foldMap (\a -> mlookup a inputs) as
+        order = (ids <> rest) <#> \id -> elemIndex id edgeIds # maybe "?" ((_ + 1) >>> show)
+        rest = filter (\id -> id `notElem` ids) edgeIds
+
+    levelOutputs :: Array a -> Array Int
+    levelOutputs = foldMap (\a -> mlookup a outputs)
+
+mfromFoldable :: ∀ f k v. Foldable f => Ord k => Monoid v => f (k /\ v) -> Map k v
+mfromFoldable = fromFoldableWith (flip (<>))
+
+mlookup :: ∀ k v. Ord k => Monoid v => k -> Map k v -> v
+mlookup k = lookup k >>> fold
+
+nextChar :: Char -> Int -> String
+nextChar c i = fromCharCode (toCharCode c + i) # maybe "?" singleton
+
+rangeEx :: Int -> Int -> Array Int
+rangeEx x y = if y > x then x .. (y - 1) else []
+
+infix 8 rangeEx as ..<
+
+chunks :: ∀ a. Int -> Array a -> Array (Array a)
+chunks _ [] = []
+chunks n xs = [take n xs] <> (chunks n $ drop n xs)

stbx-lang/src/Language/Statebox/Wiring/Parser.purs

@@ -18,8 +18,8 @@ import Language.Statebox.Hypergraph (NodeF(..), HyperEdgeF(..), GElemF(..))
 import Language.Statebox.Wiring.AST (Node(..), HyperEdge(..), LabelWithSpan, GElem(..))
 import Language.Statebox.Parser.Util (getPosition, hspaces, inside, isAlphaNum, someOf)
 
-graph1 :: Parser String (List GElem)
-graph1 = (gElem `inside` hspaces) `sepEndBy` (semicolon <|> newlines)
+diagram :: Parser String (List GElem)
+diagram = (gElem `inside` hspaces) `sepEndBy` (semicolon <|> newlines)
   where
     newlines = skipMany1 (char '\n')
     semicolon = const unit <$> char ';'

stbx-lang/test/Wiring.purs

@@ -5,46 +5,63 @@ import Data.Bifunctor (lmap)
 import Data.List as List
 import Data.List (List)
 import Data.String (trim)
-import Language.Statebox as Statebox
+import Language.Statebox as Stbx
 import Language.Statebox.Hypergraph (HyperEdgeF(..), GElemF(..))
 import Language.Statebox.Wiring.AST (Label, stripSpan)
-import Language.Statebox.Wiring.Generator.Diagram (toDiagramWithName)
+import Language.Statebox.Wiring.Generator.Diagram (toDiagramWithName) as DiagramV1
+import Language.Statebox.Wiring.Generator.DiagramV2 as DiagramV2
 import Statebox.Core.Types (Diagram)
-import Test.Spec                  (Spec, describe, it)
-import Test.Spec.Assertions       (shouldEqual)
+import Test.Spec (Spec, describe, it)
+import Test.Spec.Assertions (shouldEqual)
+
+import Debug.Trace (spy)
 
 spec :: Spec Unit
 spec = do
   describe "Statebox wiring compiler" do
-    it "should parse wirings correctly" do
-      let ast = Statebox.parseWiring wiring1src
-      let diagram1 = toDiagramWithName "dummy" <$> ast
-      (ast # map (map (lmap stripSpan))) `shouldEqual` pure wiring1expected
-      diagram1 `shouldEqual` pure diagram1expected
-
-wiring1src :: String
-wiring1src = trim """
-a1 -> b1, b2
-b1 -> d1
-b2 -> c1
-c1 -> d1
-"""
-
-wiring1expected :: List (GElemF List Label Unit)
-wiring1expected = mkAst
-  [ mkEdge ["a1"] ["b1", "b2"]
-  , mkEdge ["b1"] ["d1"]
-  , mkEdge ["b2"] ["c1"]
-  , mkEdge ["c1"] ["d1"]
-  ]
-
-diagram1expected :: Diagram
-diagram1expected =
-  { name: "dummy"
-  , width: 5
-  , pixels: [ 1, 1, 2, 3, 5, 2, 3, 4, 5, 4 ]
-  , names: [ "a1", "b1", "b2", "d1", "c1" ]
-  }
+    let
+      diagramSrc :: String
+      diagramSrc = trim """
+        a1 -> b1, b2
+        b1 -> d1
+        b2 -> c1
+        c1 -> d1
+        """
+
+      diagramAstExpected :: List (GElemF List Label Unit)
+      diagramAstExpected = mkAst
+        [ mkEdge ["a1"] ["b1", "b2"]
+        , mkEdge ["b1"] ["d1"]
+        , mkEdge ["b2"] ["c1"]
+        , mkEdge ["c1"] ["d1"]
+        ]
+
+      diagramV1Expected :: Diagram
+      diagramV1Expected =
+        { name: "diagramV1"
+        , width: 5
+        , pixels: [ 1, 1, 2, 3, 5, 2, 3, 4, 5, 4 ]
+        , names: [ "a1", "b1", "b2", "d1", "c1" ]
+        }
+
+    it "should parse a diagram correctly" do
+      let
+        diagramAstWithSpans = Stbx.parseDiagram diagramSrc
+        diagramAst = diagramAstWithSpans # map (map (lmap stripSpan))
+      diagramAst `shouldEqual` pure diagramAstExpected
+
+    it "should compile a diagram AST to the corresponding Diagram (v1)" do
+      let
+        diagramAstWithSpans = Stbx.parseDiagram diagramSrc -- TODO we don't want spans here
+        diagramV1 = DiagramV1.toDiagramWithName "diagramV1" <$> diagramAstWithSpans
+      diagramV1 `shouldEqual` pure diagramV1Expected
+
+    it "should convert a Diagram (v1) to its correspondingDiagramV2 (kdmoncat)" do
+      let
+        diagramAstWithSpans = Stbx.parseDiagram diagramSrc -- TODO we don't want spans here
+        diagramV2  = DiagramV2.fromDiagram     $  diagramV1Expected
+        diagramV2' = DiagramV2.fromDiagramAst <$> diagramAstWithSpans
+      pure diagramV2 `shouldEqual` diagramV2'
 
 --------------------------------------------------------------------------------
 -- graph DSL