|
| 1 | +module Language.Statebox.Wiring.Generator.DiagramV2 where |
| 2 | + |
| 3 | +import Prelude |
| 4 | +import Data.Array (zipWith, take, drop, concat, length, (..), (!!), uncons, elemIndex, filter) |
| 5 | +import Data.Char (fromCharCode, toCharCode) |
| 6 | +import Data.Foldable (class Foldable, maximum, intercalate, foldMap, fold, notElem) |
| 7 | +import Data.FoldableWithIndex (foldMapWithIndex) |
| 8 | +import Data.FunctorWithIndex (mapWithIndex) |
| 9 | +import Data.List (List) |
| 10 | +import Data.Map (Map, fromFoldableWith, lookup, union, toUnfoldable) |
| 11 | +import Data.Map.Internal (keys) |
| 12 | +import Data.Maybe (maybe, fromMaybe) |
| 13 | +import Data.String.CodeUnits (singleton) |
| 14 | +import Data.TraversableWithIndex (mapAccumLWithIndex) |
| 15 | +import Data.Tuple (snd) |
| 16 | +import Data.Tuple.Nested ((/\), type (/\)) |
| 17 | +import Data.Function.Memoize (memoize, class Tabulate) |
| 18 | +import Statebox.Core.Types (Diagram) |
| 19 | + |
| 20 | +import Language.Statebox.Wiring.Generator (Edges, toIndexedGraph, getEdges) |
| 21 | +import Language.Statebox.Wiring.AST (GElem) |
| 22 | + |
| 23 | +-- | A kdmoncat-compatible diagram in source code representation. |
| 24 | +type DiagramV2 = |
| 25 | + { pixels :: String |
| 26 | + , context :: String |
| 27 | + } |
| 28 | + |
| 29 | +fromDiagramAst :: List GElem -> DiagramV2 |
| 30 | +fromDiagramAst ast = fromEdges (_ - 1) name edges |
| 31 | + where |
| 32 | + { graph, names } = toIndexedGraph ast |
| 33 | + edges = getEdges graph |
| 34 | + name id = names !! (id - 1) # fromMaybe "?" |
| 35 | + |
| 36 | +fromDiagram :: Diagram -> DiagramV2 |
| 37 | +fromDiagram { width, pixels, names } = fromEdges (_ - 1) name edges |
| 38 | + where |
| 39 | + rows = chunks width pixels |
| 40 | + edges = concat $ zipWith (zipWith (\src tgt -> { src, tgt })) rows (drop 1 rows) |
| 41 | + name id = names !! (id - 1) # fromMaybe "?" |
| 42 | + |
| 43 | +fromEdges :: ∀ a. Ord a => Tabulate a => (a -> Int) -> (a -> String) -> Edges a -> DiagramV2 |
| 44 | +fromEdges fromEnum name edges = { pixels, context } |
| 45 | + where |
| 46 | + pixels = (0 .. height) <#> row # intercalate "\n" |
| 47 | + context = [nodeTypes, swapTypes] # intercalate "\n" |
| 48 | + |
| 49 | + predecessors :: Map a (Array a) |
| 50 | + predecessors = edges <#> (\{ src, tgt } -> tgt /\ [src]) # mfromFoldable |
| 51 | + |
| 52 | + successors :: Map a (Array a) |
| 53 | + successors = edges <#> (\{ src, tgt } -> src /\ [tgt]) # mfromFoldable |
| 54 | + |
| 55 | + inputs :: Map a (Array Int) |
| 56 | + inputs = edges # mapWithIndex (\i { tgt } -> tgt /\ [i]) # mfromFoldable |
| 57 | + |
| 58 | + outputs :: Map a (Array Int) |
| 59 | + outputs = edges # mapWithIndex (\i { src } -> src /\ [i]) # mfromFoldable |
| 60 | + |
| 61 | + level :: a -> Int |
| 62 | + level = memoize \a -> mlookup a predecessors <#> level # maximum # maybe 0 (_ + 1) |
| 63 | + |
| 64 | + nodes :: List a |
| 65 | + nodes = (successors `union` predecessors) # keys |
| 66 | + |
| 67 | + grouped :: Array (Array a) |
| 68 | + grouped = nodes <#> (\id -> level id /\ [id]) # mfromFoldable # toUnfoldable <#> snd |
| 69 | + |
| 70 | + width = length grouped |
| 71 | + height = grouped <#> length # maximum # fromMaybe 0 |
| 72 | + |
| 73 | + typeStr :: a -> Map a (Array a) -> (a -> String) -> String |
| 74 | + typeStr a m f = mlookup a m <#> f # intercalate " " |
| 75 | + |
| 76 | + pixel :: a -> String |
| 77 | + pixel a = nextChar 'A' (fromEnum a) |
| 78 | + |
| 79 | + nodeType :: a -> String |
| 80 | + nodeType a = name a <> "@" <> pixel a <> ": " <> typeStr a predecessors (\b -> name b <> "_" <> name a) |
| 81 | + <> " -> " <> typeStr a successors (\b -> name a <> "_" <> name b) |
| 82 | + nodeTypes :: String |
| 83 | + nodeTypes = map nodeType nodes # intercalate "\n" |
| 84 | + |
| 85 | + row :: Int -> String |
| 86 | + row y = grouped # foldMapWithIndex \x g -> |
| 87 | + ((g !! y) # maybe (if x > 0 && x < width - 1 then nextChar 'n' (x - 1) else " ") pixel) <> |
| 88 | + if x < width - 1 then nextChar 'a' x else "" |
| 89 | + |
| 90 | + swapTypes :: String |
| 91 | + swapTypes = grouped |
| 92 | + # uncons |
| 93 | + <#> (\{ head, tail } -> mapAccumLWithIndex mkSwap (levelOutputs head) tail) |
| 94 | + # maybe "" (_.value >>> intercalate "\n") |
| 95 | + |
| 96 | + mkSwap :: Int -> Array Int -> Array a -> { accum :: Array Int, value :: String } |
| 97 | + mkSwap i edgeIds as = { accum: levelOutputs as <> rest, value } |
| 98 | + where |
| 99 | + value = nextChar 'a' i <> ": [" <> intercalate " " order <> "]\n" <> |
| 100 | + nextChar 'n' i <> ": [" <> intercalate " " ((1 ..< (length rest + 1)) <#> show) <> "]" |
| 101 | + ids = foldMap (\a -> mlookup a inputs) as |
| 102 | + order = (ids <> rest) <#> \id -> elemIndex id edgeIds # maybe "?" ((_ + 1) >>> show) |
| 103 | + rest = filter (\id -> id `notElem` ids) edgeIds |
| 104 | + |
| 105 | + levelOutputs :: Array a -> Array Int |
| 106 | + levelOutputs = foldMap (\a -> mlookup a outputs) |
| 107 | + |
| 108 | +mfromFoldable :: ∀ f k v. Foldable f => Ord k => Monoid v => f (k /\ v) -> Map k v |
| 109 | +mfromFoldable = fromFoldableWith (flip (<>)) |
| 110 | + |
| 111 | +mlookup :: ∀ k v. Ord k => Monoid v => k -> Map k v -> v |
| 112 | +mlookup k = lookup k >>> fold |
| 113 | + |
| 114 | +nextChar :: Char -> Int -> String |
| 115 | +nextChar c i = fromCharCode (toCharCode c + i) # maybe "?" singleton |
| 116 | + |
| 117 | +rangeEx :: Int -> Int -> Array Int |
| 118 | +rangeEx x y = if y > x then x .. (y - 1) else [] |
| 119 | + |
| 120 | +infix 8 rangeEx as ..< |
| 121 | + |
| 122 | +chunks :: ∀ a. Int -> Array a -> Array (Array a) |
| 123 | +chunks _ [] = [] |
| 124 | +chunks n xs = [take n xs] <> (chunks n $ drop n xs) |
0 commit comments