From 7ab262cd2bc8ff28df1a29861f299c3326aac223 Mon Sep 17 00:00:00 2001 From: David Mosbach Date: Sat, 11 Mar 2023 00:53:26 +0100 Subject: [PATCH] init --- .gitignore | 3 + app/Export.hs | 43 +++++++ app/Main.hs | 52 ++++++++ app/Workflow.hs | 160 ++++++++++++++++++++++++ editor.css | 7 ++ editor.html | 23 ++++ editor.js | 257 ++++++++++++++++++++++++++++++++++++++ workflow-visualiser.cabal | 41 ++++++ 8 files changed, 586 insertions(+) create mode 100644 .gitignore create mode 100644 app/Export.hs create mode 100644 app/Main.hs create mode 100644 app/Workflow.hs create mode 100644 editor.css create mode 100644 editor.html create mode 100644 editor.js create mode 100644 workflow-visualiser.cabal diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..5e00d0d --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +/dist-newstyle +CHANGELOG.md +test.json \ No newline at end of file diff --git a/app/Export.hs b/app/Export.hs new file mode 100644 index 0000000..12779ae --- /dev/null +++ b/app/Export.hs @@ -0,0 +1,43 @@ +{-# Language OverloadedStrings #-} + +module Export where + + ----------------Imports---------------- + + import Data.Aeson + import Data.Map hiding (fromList) + import Data.Vector hiding ((!)) + import Workflow (NodeData(..), EdgeData(..), GraphData(..)) + + --------------------------------------- + + + ---------------Instances--------------- + + instance ToJSON NodeData where + toJSON (NData d) = Array (fromList $ foldrWithKey newObject [] d) where + newObject :: String -> Map String String -> [Value] -> [Value] + newObject ident values result = object [ + "id" .= ident, + "name" .= values ! "name", + "val" .= show 5, -- Todo adjust to number of edges + "stateData" .= object [ + "viewers" .= values ! "viewers", + "final" .= values ! "final"]] : result + -- toEncoding = genericToEncoding defaultOptions + + instance ToJSON EdgeData where + toJSON (EData d) = Array (fromList $ foldrWithKey newObject [] d) where + newObject :: String -> Map String String -> [Value] -> [Value] + newObject ident values result = object [ + "id" .= ident, + "name" .= values ! "name", + "source" .= values ! "source", + "target" .= values ! "target", + "actionData" .= object [ + "mode" .= values ! "mode"]] : result + + instance ToJSON GraphData where + toJSON (GData (nd, ed)) = object ["states" .= toJSON nd, "actions" .= toJSON ed] + + --------------------------------------- \ No newline at end of file diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..a58b7f9 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,52 @@ +module Main where + + ----------------Imports---------------- + + import System.Environment (getArgs) + import Data.Yaml (ParseException, decodeEither') + import Data.Aeson (encode, encodeFile) + + import qualified Data.ByteString.Char8 as BS + import Workflow (Workflow, buildData) + import Export + import Data.Maybe (fromJust, isNothing) + import Data.Either (isLeft, fromLeft, fromRight) + import Control.Exception (throw) + + --------------------------------------- + + + ----------------Methods---------------- + + -- | Required command line arguments: + -- 1. A workflow source file (YAML) + -- 2. A graph data target file (JSON) + main :: IO () + main = getArgs >>= process >>= finish where + process :: [String] -> IO Bool + process args = if length args /= 2 + then print "Please provide (1) a source and (2) a target file" >> return True + else generateJSON args >> return False + finish :: Bool -> IO () + finish abort = if abort then return () else print "Done." + + + + -- | Imports the YAML document specified in the first command line argument and + -- exports the graph data to the JSON file specified in the second argument. + generateJSON :: [String] -> IO () + generateJSON args = do + content <- BS.readFile (head args) + let decoded = decodeEither' content :: Either ParseException Workflow + if isLeft decoded then throw (fromLeft undefined decoded) else do + let yaml = fromRight undefined decoded + -- let GData (nodeData, edgeData) = buildData yaml + -- putStrLn $ "\nNode Data:\n\n" ++ show nodeData + -- putStrLn $ "\nEdge Data:\n\n" ++ show edgeData + -- encodeFile (last args) $ GData (nodeData, edgeData) + encodeFile (last args) $ buildData yaml + + --------------------------------------- + +-- https://stackoverflow.com/questions/59903779/how-to-parse-json-with-field-of-optional-and-variant-type-in-haskell +-- https://stackoverflow.com/questions/21292428/reading-yaml-lists-of-objects-in-haskell \ No newline at end of file diff --git a/app/Workflow.hs b/app/Workflow.hs new file mode 100644 index 0000000..d3465c3 --- /dev/null +++ b/app/Workflow.hs @@ -0,0 +1,160 @@ +{-# Language DuplicateRecordFields, + NoFieldSelectors, + OverloadedRecordDot, + OverloadedStrings, + DeriveGeneric #-} + +module Workflow where + + ----------------Imports---------------- + + import Data.Yaml + import Control.Applicative hiding (empty) + import GHC.Generics (Generic) + import Data.Map + import Data.Maybe (fromMaybe, isNothing, fromJust) + import Data.Text (pack) + + --------------------------------------- + + + ---------Data Types & Instances-------- + + -- | Outer structure of a workflow, i.e. nodes and stages. + data Workflow = Workflow { + nodes :: Map String State, + stages :: Maybe Value + } deriving (Show, Generic) + + instance FromJSON Workflow + + + -- | Structure of a node. + data State = State { + viewers :: Maybe StateViewers, + payload :: Maybe Value, + final :: Maybe Final, + edges :: Maybe (Map String Action), + messages :: Maybe Value + } deriving (Show, Generic) + + instance FromJSON State where + parseJSON (Object o) = State <$> + o .:? "viewers" <*> + o .:? "payload-view" <*> + o .:? "final" <*> + o .:? "edges" <*> + o .:? "messages" + parseJSON _ = error "unexpected state data format" + + + -- | Wrapper for the `final` value of any node. + newtype Final = Final {final :: String} deriving (Show, Generic) + + instance FromJSON Final where + parseJSON v = case v of + String _ -> Final <$> parseJSON v + Bool x -> Final <$> parseJSON (String . pack . show $ x) + + + -- | Structure of the `viewers` object of any node. + data StateViewers = StateViewers { + name :: Either Label String, + viewers :: Maybe Value + } deriving (Show, Generic) + + instance FromJSON StateViewers where + parseJSON (Object o) = StateViewers <$> + ((Left <$> o .: "display-label") <|> (Right <$> o .: "display-label")) <*> + o .:? "viewers" + parseJSON _ = error "unexpected stateViewers data format" + + + + -- | Structure of the @display-label@ object of any node or edge. + data Label = Label { + fallback :: Maybe String, + translations :: Maybe Value + } deriving (Show, Generic) + + instance FromJSON Label + + + -- | Structure of an edge. + data Action = Action { + mode :: Maybe String, + source :: Maybe String, + name :: Maybe Label, + actors :: Maybe Value, + viewActor :: Maybe Value, + viewers :: Maybe Value, + messages :: Maybe Value, + form :: Maybe Value + } deriving (Show, Generic) + + instance FromJSON Action where + parseJSON (Object o) = Action <$> + o .:? "mode" <*> + o .:? "source" <*> + o .:? "display-label" <*> + o .:? "actors" <*> + o .:? "view-actor" <*> + o .:? "viewers" <*> + o .:? "messages" <*> + o .:? "form" + parseJSON _ = error "unexpected action data format" + + + -- | Data of all nodes prepared for JSON encoding. + newtype NodeData = NData (Map String (Map String String)) deriving (Show, Generic) + -- | Data of all edges prepared for JSON encoding. + newtype EdgeData = EData (Map String (Map String String)) deriving (Show, Generic) + -- | Data of the entire workflow prepared for JSON encoding. + newtype GraphData = GData (NodeData , EdgeData) deriving (Show, Generic) + + --------------------------------------- + + + ---------------Constants--------------- + + -- | Name of the source of an initial action. + initID = "@@INIT" + + --------------------------------------- + + + ----------------Methods---------------- + + buildData :: Workflow -> GraphData + buildData wf = GData $ foldrWithKey analyse (NData empty, EData empty) nodes where + nodes = insert initID (State {final = Just $ Final "False", + viewers = Just $ StateViewers (Left (Label (Just initID) Nothing)) Nothing, + payload = Nothing, + edges = Nothing, + messages = Nothing}) wf.nodes + analyse :: String -> State -> (NodeData , EdgeData) -> (NodeData , EdgeData) + analyse k s (NData n, ed@(EData e)) = (NData $ insert k (extract s) n, updateEdges k s.edges ed) + extract :: State -> Map String String + extract s = fromList [("name", name), ("viewers", viewers), ("final", final)] where + (name, viewers) = case s.viewers of + Nothing -> ("", "") + Just x -> case x.name of + Left y -> (fromMaybe "" y.fallback, show x.viewers) + Right y -> (y, show x.viewers) + final = case s.final of + Nothing -> "" + Just x -> x.final + updateEdges :: String -> Maybe (Map String Action) -> EdgeData -> EdgeData + updateEdges _ Nothing e = e + updateEdges targetID (Just edges) (EData e) = EData $ foldrWithKey (\ k action eData -> insert (k ++ "_@_" ++ targetID) (newData k action targetID) eData) e edges + newData :: String -> Action -> String -> Map String String + newData ident a targetID = fromList [("name", name), ("source", source), ("target", targetID), ("mode", mode)] where + name = if isNothing a.name + then ident + else case (fromJust a.name).fallback of + Nothing -> show a.name + Just x -> x + source = fromMaybe initID a.source + mode = fromMaybe "" a.mode + + --------------------------------------- \ No newline at end of file diff --git a/editor.css b/editor.css new file mode 100644 index 0000000..3ab857d --- /dev/null +++ b/editor.css @@ -0,0 +1,7 @@ +/* .body { + margin: 50px 50px 50px 50px; +} + +#editor { + border: 10px solid red; +} */ \ No newline at end of file diff --git a/editor.html b/editor.html new file mode 100644 index 0000000..23700f1 --- /dev/null +++ b/editor.html @@ -0,0 +1,23 @@ + + + + + + + + + + + +
+ +
+ hello +
+ + + \ No newline at end of file diff --git a/editor.js b/editor.js new file mode 100644 index 0000000..f122803 --- /dev/null +++ b/editor.js @@ -0,0 +1,257 @@ +var workflow = {} + +// fetch('./test.json') +// .then((response) => response.json()) +// .then((data) => { +// for (var key in data) +// workflow[key] = data[key]; +// }); + +// Counters for placeholder IDs of states/actions added via GUI +var stateIdCounter = workflow.states ? workflow.states.length : 0; +var actionIdCounter = workflow.states ? workflow.actions.length : 0; + + +var selfLoops = {}; // All edges whose targets equal their sources. +var overlappingEdges = {}; // All edges whose target and source are connected by further. +const selfLoopCurvMin = 0.5; // Minimum curvature of a self loop. +const curvatureMinMax = 0.2; // Minimum/maximum curvature (1 +/- x) of overlapping edges. + +var selection = null; // The currently selected node/edge. + + +/** + * Identifies and stores self loops as well as overlapping edges (i.e. multiple edges sharing the + * same source and target). + */ +function identifyOverlappingEdges() { + selfLoops = {}; + overlappingEdges = {}; + workflow.actions.forEach(edge => { + var source = typeof(edge.source) === 'string' ? edge.source : edge.source.id; + var target = typeof(edge.target) === 'string' ? edge.target : edge.target.id; + var pre = source <= target ? source : target; + var post = source <= target ? target : source; + edge.nodePairId = pre + '_' + post; + var category = edge.source === edge.target ? selfLoops : overlappingEdges; + if (!category[edge.nodePairId]) category[edge.nodePairId] = []; + category[edge.nodePairId].push(edge); + }); +} + + +/** + * Computes the curvature of the loops stored in `selfLoops` and overlapping edges + * stored in `overlappingEdges`. + */ +function computeCurvatures() { + // Self loops + Object.keys(selfLoops).forEach(id => { + var edges = selfLoops[id]; + for (let i = 0; i < edges.length; i++) + edges[i].curvature = selfLoopCurvMin + i / 10; + }); + // Overlapping edges + Object.keys(overlappingEdges) + .filter(nodePairId => overlappingEdges[nodePairId].length > 1) + .forEach(nodePairId => { + var edges = overlappingEdges[nodePairId]; + var lastIndex = edges.length - 1; + var lastEdge = edges[lastIndex]; + lastEdge.curvature = curvatureMinMax; + let delta = 2 * curvatureMinMax / lastIndex; + for (let i = 0; i < lastIndex; i++) { + edges[i].curvature = - curvatureMinMax + i * delta; + if (lastEdge.source !== edges[i].source) edges[i].curvature *= -1; + } + }); +} + + +/** + * Marks the given item as selected. + * @param {*} item The node or edge to select. + */ +function select(item) { + selection = item; + console.log(item); + // TODO +} + + +/** + * Updates the nodes and edges of the workflow graph. + */ +function updateGraph() { + identifyOverlappingEdges() + computeCurvatures() + Graph.graphData({nodes: workflow.states, links: workflow.actions}); +} + + +/** + * Adds a new action between two states. + * @param {*} source The source state. + * @param {*} target The target state. + */ +function connect(source, target) { + let linkId = actionIdCounter ++; + action = {id: linkId, source: source, target: target, name: 'action_' + linkId}; + workflow.actions.push(action); + updateGraph(); +} + + +/** + * Adds a new state to the workflow. + * @param {*} x The x coordinate on the canvas. + * @param {*} y The y coordinate on the canvas. + * @returns The new state. + */ +function addState(x, y) { + let nodeId = stateIdCounter ++; + state = {id: nodeId, x: x, y: y, name: 'state_' + nodeId, fx: x, fy: y, val: 5}; + workflow.states.push(state); + updateGraph(); + return state; +} + + +/** + * Removes an edge from the workflow. + * @param {*} action The action to remove. + */ +function removeAction(action) { + workflow.actions.splice(workflow.actions.indexOf(action), 1); +} + + +/** + * Removes a state from the workflow. + * @param {*} state The state to remove. + */ +function removeState(state) { + workflow.actions + .filter(edge => edge.source === state || edge.target === state) + .forEach(edge => removeAction(edge)); + workflow.states.splice(workflow.states.indexOf(state), 1); +} + +const Graph = ForceGraph() + (document.getElementById('graph')) + .linkDirectionalArrowLength(6) + .linkDirectionalArrowRelPos(1) + .nodeColor(node => { + if (node.stateData && node.stateData.final !== 'False' && node.stateData.final !== '') { + if (node.stateData.final === 'True' || node.stateData.final === 'ok') { + return selection === node ? '#a4eb34' : '#7fad36'; + } else if (node.stateData.final === 'not-ok') { + return selection === node ? '#f77474' : '#f25050'; + } else { + //console.log(node.stateData.final); + } + } else if (node.name === '@@INIT') { + return selection === node ? '#e8cd84' : '#d1ad4b'; + } else { + return selection === node ? '#5fbad9' : '#4496b3'; + } + }) + .linkColor(edge => selection === edge ? 'black' : '#999999') + .linkCurvature('curvature') + .linkCanvasObjectMode(() => 'after') + .linkCanvasObject((edge, context) => { + const MAX_FONT_SIZE = 4; + const LABEL_NODE_MARGIN = Graph.nodeRelSize() * edge.source.val * 1.5; + + const source = edge.source; + const target = edge.target; + const curvature = edge.curvature || 0; + + var textPos = (source === target) ? {x: source.x, y: source.y} : Object.assign(...['x', 'y'].map(c => ({ + [c]: source[c] + (target[c] - source[c]) / 2 + }))); + + const edgeVector = {x: target.x - source.x, y: target.y - source.y}; + if (source !== target) { + var evLength = Math.sqrt(Math.pow(edgeVector.x, 2) + Math.pow(edgeVector.y, 2)); + var perpendicular = {x: edgeVector.x, y: (-Math.pow(edgeVector.x, 2) / edgeVector.y)}; + var pLength = Math.sqrt(Math.pow(perpendicular.x, 2) + Math.pow(perpendicular.y, 2)); + perpendicular.x = perpendicular.x / pLength; + perpendicular.y = perpendicular.y / pLength; + var fromSource = {x: source.x + perpendicular.x, y: source.y + perpendicular.y}; + // If source would cycle around target in clockwise direction, would fromSource point into this direction? + // If not, the perpendicular vector must be flipped in order to ensure that the label is displayed on the + // intended curved edge. + var isClockwise = (source.x < target.x && fromSource.y > source.y) || + (source.x > target.x && fromSource.y < source.y) || + (source.x === target.x && ((source.y < target.y && fromSource.x < source.x) || + source.y > target.y && fromSource.x > source.x)); + var offset = 0.5 * evLength * (isClockwise ? -curvature : curvature); + textPos = {x: textPos.x + perpendicular.x * offset, y: textPos.y + perpendicular.y * offset}; + } else if (edge.__controlPoints) { // Position label relative to the Bezier control points of the self loop + edgeVector.x = edge.__controlPoints[2] - edge.__controlPoints[0]; + edgeVector.y = edge.__controlPoints[3] - edge.__controlPoints[1]; + var ctrlCenter = {x: edge.__controlPoints[0] + (edge.__controlPoints[2] - edge.__controlPoints[0]) / 2, + y: edge.__controlPoints[1] + (edge.__controlPoints[3] - edge.__controlPoints[1]) / 2}; + var fromSource = {x: ctrlCenter.x - source.x, y: ctrlCenter.y - source.y}; + var fromSrcLen = Math.sqrt(Math.pow(fromSource.x, 2) + Math.pow(fromSource.y, 2)); + fromSource.x /= fromSrcLen; + fromSource.y /= fromSrcLen; + // The distance of the control point is 70 * curvature. Slightly more than half of it is appropriate here: + textPos = {x: source.x + fromSource.x * 37 * curvature, y: source.y + fromSource.y * 37 * curvature}; + } + + const maxTextLength = (source !== target) ? Math.sqrt(Math.pow(edgeVector.x, 2) + Math.pow(edgeVector.y, 2)) - LABEL_NODE_MARGIN + : 1.5 * Math.sqrt(4 * source.val); + + var textAngle = Math.atan2(edgeVector.y, edgeVector.x); + // maintain label vertical orientation for legibility + if (textAngle > Math.PI / 2) textAngle = -(Math.PI - textAngle); + if (textAngle < -Math.PI / 2) textAngle = -(-Math.PI - textAngle); + + var label = edge.name; + + // estimate fontSize to fit in link length + //context.font = '1px Sans-Serif'; + const fontSize = MAX_FONT_SIZE;// Math.min(MAX_FONT_SIZE, maxTextLength / context.measureText(label).width); + context.font = `${fontSize}px Sans-Serif`; + + var textLen = context.measureText(label).width; + if (textLen > maxTextLength) { + var allowedLen = maxTextLength * (label.length / textLen); + label = label.substring(0, allowedLen); + if (label !== edge.name) label += '...'; + textLen = context.measureText(label).width; + } + + const bckgDimensions = [textLen, fontSize]; + + // draw text label (with background rect) + context.save(); + context.translate(textPos.x, textPos.y); + context.rotate(textAngle); + + context.fillStyle = 'rgba(255, 255, 255, 0.8)'; + context.fillRect(- bckgDimensions[0] / 2, - bckgDimensions[1] / 2, ...bckgDimensions); + + context.textAlign = 'center'; + context.textBaseline = 'middle'; + context.fillStyle = selection === edge ? 'black' : 'darkgrey'; + context.fillText(label, 0, 0); + context.restore(); + }) + .onNodeDragEnd(node => { + node.fx = node.x; + node.fy = node.y; + }) + .onNodeClick((node, _) => select(node)) + .onNodeRightClick((node, _) => removeState(node)) + .onLinkClick((edge, _) => select(edge)) + .onLinkRightClick((edge, _) => removeAction(edge)) + .onBackgroundClick(event => { + var coords = Graph.screen2GraphCoords(event.layerX, event.layerY); + var newState = addState(coords.x, coords.y); + selection = newState; + }); + +updateGraph(); \ No newline at end of file diff --git a/workflow-visualiser.cabal b/workflow-visualiser.cabal new file mode 100644 index 0000000..42615c1 --- /dev/null +++ b/workflow-visualiser.cabal @@ -0,0 +1,41 @@ +cabal-version: 2.4 +name: workflow-visualiser +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +-- license: +author: David Mosbach +maintainer: david.mosbach@live.de + +-- A copyright notice. +-- copyright: +-- category: +extra-source-files: CHANGELOG.md + +executable workflow-visualiser + main-is: Main.hs + + -- Modules included in this executable, other than Main. + other-modules: Workflow, + Export + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + build-depends: base ^>=4.16.3.0, + yaml >= 0.11.11.0, + aeson >= 2.1.2.0, + bytestring, + containers, + text, + vector + hs-source-dirs: app + default-language: Haskell2010