From 28d3d0544e860e0fed5b7924c834a0500fabaa9a Mon Sep 17 00:00:00 2001
From: Hans-Peter Deifel <hpd@hpdeifel.de>
Date: Sun, 9 Dec 2018 20:42:40 +0100
Subject: [PATCH] web: Implement graph view
---
web/assets/custom.css | 14 +++++
web/assets/index.html | 41 +++++++++++++
web/backend/Main.hs | 46 +++++++++++++++
web/backend/copar-web.cabal | 1 +
web/frontend/src/Main.elm | 115 +++++++++++++++++++++++++-----------
5 files changed, 184 insertions(+), 33 deletions(-)
diff --git a/web/assets/custom.css b/web/assets/custom.css
index 44b6bce..800934d 100644
--- a/web/assets/custom.css
+++ b/web/assets/custom.css
@@ -6,6 +6,10 @@
font-weight: 300;
}
+.body {
+ height: 100%;
+}
+
.header {
background-color: rgb(0, 120, 231);
padding-top: 1em;
@@ -21,6 +25,7 @@
.output {
padding: 1em;
+ height: 100%;
}
.error-message {
@@ -47,3 +52,12 @@
padding: 0px;
list-style: none;
}
+
+#graph {
+ display: block;
+ height: 400px;
+}
+
+#source {
+ height: 400px;
+}
diff --git a/web/assets/index.html b/web/assets/index.html
index 545171b..cb68d0e 100644
--- a/web/assets/index.html
+++ b/web/assets/index.html
@@ -3,6 +3,9 @@
<head>
<meta charset="UTF-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
+ <script type="text/javascript" src="https://unpkg.com/cytoscape@3.3.0/dist/cytoscape.min.js"></script>
+ <script src="https://unpkg.com/dagre@0.7.4/dist/dagre.js"></script>
+ <script type="text/javascript" src="https://unpkg.com/cytoscape-dagre@2.2.2/cytoscape-dagre.js"></script>
<script src="main.js"></script>
<link rel="stylesheet" href="https://unpkg.com/purecss@1.0.0/build/pure-min.css" integrity="sha384-nn4HPE8lTHyVtfCBi5yW9d20FjT8BJwUXyWZT9InLYax14RDjBj46LmSztkmNP9w" crossorigin="anonymous">
<link rel="stylesheet" href="https://unpkg.com/purecss@1.0.0/build/grids-responsive-min.css">
@@ -15,6 +18,44 @@
var app = Elm.Main.init({
node: document.getElementById('elm')
});
+ app.ports.drawGraph.subscribe(function(data) {
+ requestAnimationFrame(function() {
+
+ console.log(data);
+
+ cytoscape({
+ container: document.getElementById('graph'),
+ elements: data,
+ style: [
+ {
+ selector: 'edge',
+ style: {
+ 'curve-style': 'bezier',
+ 'target-arrow-shape': 'triangle',
+ 'control-point-step-size': '70px',
+ 'width': '3'
+ }
+ },
+ {
+ selector: '[label]',
+ style: {
+ 'label': 'data(label)',
+ 'text-valign': 'center',
+ 'background-color': 'rgb(0, 120, 231)',
+ 'color': 'white',
+ 'width': 'label',
+ 'height': 'label',
+ 'padding-relative-to': 'max',
+ 'padding': '2em'
+ }
+ }
+ ],
+ layout: {
+ name: 'dagre',
+ }
+ })
+ })
+ })
</script>
</body>
</html>
diff --git a/web/backend/Main.hs b/web/backend/Main.hs
index a459742..1590e37 100644
--- a/web/backend/Main.hs
+++ b/web/backend/Main.hs
@@ -8,6 +8,7 @@ import System.Environment
import System.IO
import Data.Function ( (&) )
import Data.Maybe (fromJust)
+import Data.Bifunctor
import Web.Scotty
import qualified Data.Text.Lazy.Encoding as TL
@@ -26,6 +27,8 @@ import Network.Wai.Handler.Warp ( setPort
import Data.Aeson ((.=))
import qualified Data.Aeson as Json
import qualified Data.HashMap.Strict as HM
+import Data.Vector (Vector)
+import qualified Data.Vector as V
import qualified Copar.Parser as P
import Copar.Algorithm
@@ -33,6 +36,7 @@ import Copar.PartitionPrinter
import qualified Data.Partition as Partition
import Data.Partition (Partition, State)
import Data.MorphismEncoding (Encoding)
+import qualified Data.MorphismEncoding as Encoding
import Copar.Coalgebra.Parser (SymbolTable, fromSymbolTable)
data Reply = Error Text | Result [[State]] SymbolTable
@@ -56,6 +60,44 @@ doRefine input = case P.parseCoalgebra P.defaultConfig "input" input of
in Result (restrictPartitionToSort1 encoding partition) symbolTable
+data GraphReply = GraphError Text | Graph (Encoding () ()) SymbolTable
+
+instance Json.ToJSON GraphReply where
+ toJSON (GraphError e) =
+ Json.object ["type" .= ("error" :: Text), "content" .= e]
+ toJSON (Graph encoding symbolTable) =
+ Json.object [ "type" .= ("graph" :: Text)
+ , "content" .= encodingToJson encoding symbolTable
+ ]
+
+encodingToJson :: Encoding a b -> SymbolTable -> Json.Value
+encodingToJson encoding symbolTable =
+ Json.Array $
+ V.map wrapData
+ (V.imap encodeState (Encoding.structure encoding)
+ <> V.imap encodeEdges (Encoding.edges encoding))
+
+ where
+ wrapData x = Json.object ["data" .= x]
+ encodeState i _ =
+ Json.object (("id" .= ("s" ++ show i)):label i)
+ encodeEdges i (Encoding.Edge from _ to) =
+ Json.object [ "id" .= ("e" ++ show i)
+ , "source" .= state from
+ , "target" .= state to
+ ]
+ state = ("s" ++) . show
+ label i = case HM.lookup i (fromSymbolTable symbolTable) of
+ Just name -> [ "label" .= name]
+ Nothing -> []
+
+doGraph :: Text -> GraphReply
+doGraph input = case P.parseCoalgebra P.defaultConfig "input" input of
+ Left e -> GraphError (T.pack e)
+ Right (f, (symbolTable, encoding)) ->
+ Graph (bimap (const ()) (const ()) encoding) symbolTable
+
+
main :: IO ()
main = getArgs >>= \case
[path] -> do
@@ -74,6 +116,10 @@ main = getArgs >>= \case
post "/refine" $ do
input <- TL.decodeUtf8 <$> body
json . doRefine . TL.toStrict $ input
+
+ post "/graph" $ do
+ input <- TL.decodeUtf8 <$> body
+ json . doGraph . TL.toStrict $ input
_ -> do
self <- getProgName
hPutStrLn stderr $ "Usage: " ++ self ++ " ASSETS_PATH"
diff --git a/web/backend/copar-web.cabal b/web/backend/copar-web.cabal
index db5e8de..292d552 100644
--- a/web/backend/copar-web.cabal
+++ b/web/backend/copar-web.cabal
@@ -19,3 +19,4 @@ executable copar-web
, warp >= 3.2.22 && <3.3
, aeson >= 1.4.2 && <1.5
, unordered-containers >= 0.2.9 && < 0.3
+ , vector >= 0.12.0 && <0.13
diff --git a/web/frontend/src/Main.elm b/web/frontend/src/Main.elm
index 0a72ea1..b3ec818 100644
--- a/web/frontend/src/Main.elm
+++ b/web/frontend/src/Main.elm
@@ -1,11 +1,12 @@
-module Main exposing (main)
+port module Main exposing (main)
import Browser
import Html exposing (Html)
import Html.Attributes as Attr
import Html.Events as Html
import Http
-import Json.Decode as Json
+import Json.Decode as D
+import Json.Encode as E
-- MAIN
@@ -18,6 +19,7 @@ main =
, view = view
}
+port drawGraph : E.Value -> Cmd msg
-- MODEL
@@ -30,8 +32,10 @@ type alias Model =
type OutputStatus
= NothingYet
- | WaitingForResult
- | Result (Result String Blocks)
+ | WaitingForPartition
+ | PartitionResult (Result String Blocks)
+ | WaitingForGraph
+ | GraphResult (Result String ())
init : () -> (Model, Cmd Msg)
@@ -49,7 +53,9 @@ type alias Blocks = List (List String)
type Msg
= ChangeInput String
| Refine
- | GotResult (Result Error Blocks)
+ | GotPartition (Result Error Blocks)
+ | Graph
+ | GotGraph (Result Error D.Value)
update : Msg -> Model -> (Model, Cmd Msg)
@@ -58,15 +64,32 @@ update msg model =
ChangeInput newInputText ->
({ model | inputText = newInputText }, Cmd.none)
Refine ->
- ( { model | outputStatus = WaitingForResult }
+ ( { model | outputStatus = WaitingForPartition }
, refine model.inputText
)
- GotResult result ->
+ Graph ->
+ ( { model | outputStatus = WaitingForGraph }
+ , graph model.inputText
+ )
+ GotPartition result ->
+ case result of
+ Ok txt -> ( {model | outputStatus = PartitionResult (Ok txt) }, Cmd.none )
+ Err (HttpError err) ->
+ ( { model | outputStatus = PartitionResult (Err ("Request to server failed with "
+ ++ showHttpError err)) }
+ , Cmd.none
+ )
+ Err (ServerError err) -> ( { model | outputStatus = PartitionResult (Err err) }, Cmd.none )
+ GotGraph result ->
case result of
- Ok txt -> ( {model | outputStatus = Result (Ok txt) }, Cmd.none )
- Err (HttpError err) -> ( { model | outputStatus = Result (Err ("Request to server failed with " ++ showHttpError err)) }, Cmd.none )
- Err (ServerError err) -> ( { model | outputStatus = Result (Err err) }, Cmd.none )
-
+ Ok g -> ({ model | outputStatus = GraphResult (Ok ())}, drawGraph g)
+ Err (HttpError err) ->
+ ( { model | outputStatus = GraphResult (Err ("Request to server failed with "
+ ++ showHttpError err))}
+ , Cmd.none
+ )
+ Err (ServerError err) -> ( { model | outputStatus = GraphResult (Err err) }, Cmd.none )
+
showHttpError : Http.Error -> String
showHttpError err =
case err of
@@ -80,30 +103,47 @@ showHttpError err =
refine : String -> Cmd Msg
refine input =
Http.post
- {
+ {
url = "refine"
, body = Http.stringBody "text/plain" input
- , expect = Http.expectJson (GotResult << mkResult) resultDecoder
+ , expect = Http.expectJson (GotPartition << mkResult) resultDecoder
}
-mkResult : Result Http.Error (Result String Blocks) -> Result Error Blocks
+mkResult : Result Http.Error (Result String a) -> Result Error a
mkResult res =
case res of
(Ok (Ok s)) -> Ok s
(Ok (Err s)) -> Err (ServerError s)
(Err e) -> Err (HttpError e)
-
-resultDecoder : Json.Decoder (Result String Blocks)
-resultDecoder = Json.field "type" Json.string |> Json.andThen resultDecoderImpl
-
-resultDecoderImpl : String -> Json.Decoder (Result String Blocks)
+
+resultDecoder : D.Decoder (Result String Blocks)
+resultDecoder = D.field "type" D.string |> D.andThen resultDecoderImpl
+
+resultDecoderImpl : String -> D.Decoder (Result String Blocks)
resultDecoderImpl typ =
case typ of
- "error" -> Json.map Err (Json.field "content" Json.string)
- "result" -> Json.map Ok (Json.field "content" (Json.list (Json.list Json.string)))
- other -> Json.fail ("Unknown server response of type " ++ other)
+ "error" -> D.map Err (D.field "content" D.string)
+ "result" -> D.map Ok (D.field "content" (D.list (D.list D.string)))
+ other -> D.fail ("Unknown server response of type " ++ other)
-
+
+graph : String -> Cmd Msg
+graph input =
+ Http.post
+ { url = "graph"
+ , body = Http.stringBody "text/plain" input
+ , expect = Http.expectJson (GotGraph << mkResult) graphDecoder
+ }
+
+graphDecoder : D.Decoder (Result String D.Value)
+graphDecoder = D.field "type" D.string |> D.andThen graphDecoderImpl
+
+graphDecoderImpl : String -> D.Decoder (Result String D.Value)
+graphDecoderImpl typ =
+ case typ of
+ "error" -> D.map Err (D.field "content" D.string)
+ "graph" -> D.map Ok (D.field "content" D.value)
+ other -> D.fail ("Unknown server response of type " ++ other)
-- SUBSCRIPTIONS
@@ -117,14 +157,14 @@ subscriptions model =
view : Model -> Html Msg
view model =
- Html.div []
+ Html.div [Attr.class "body"]
[ Html.div [Attr.class "header"] [Html.h1 [] [ Html.text "CoPaR" ]]
, Html.div [Attr.class "pure-g"]
[ Html.div [Attr.class "pure-u-1 pure-u-md-1-2"] [viewInput model]
, Html.div [Attr.class "pure-u-1 pure-u-md-1-2"] [viewOutput model]
]
]
-
+
viewInput : Model -> Html Msg
viewInput model =
Html.div [Attr.class "input"]
@@ -134,14 +174,20 @@ viewInput model =
, Attr.rows 25
, Attr.placeholder "Coalgebra specificiation"
, Attr.value model.inputText
- , Html.onInput ChangeInput
+ , Html.onInput ChangeInput
, Attr.class "pure-input-1"
+ , Attr.id "source"
] []
- , Html.button [ if model.outputStatus == WaitingForResult
+ , Html.button [ if model.outputStatus == WaitingForPartition -- todo all waiting
then Attr.disabled True
else Html.onClick Refine
- , Attr.class "pure-button pure-button-primary pure-input-1"
+ , Attr.class "pure-button pure-button-primary pure-input-1-2"
] [ Html.text "REFINE" ]
+ , Html.button [ if model.outputStatus == WaitingForGraph -- todo all waiting
+ then Attr.disabled True
+ else Html.onClick Graph
+ , Attr.class "pure-button pure-button-primary pure-input-1-2"
+ ] [ Html.text "GRAPH" ]
]
]
@@ -151,14 +197,17 @@ viewOutput model =
[ Html.h2 [] [ Html.text "Result"]
, case model.outputStatus of
NothingYet -> Html.div [] []
- WaitingForResult -> Html.text "waiting..."
- Result (Ok res) ->
- Html.div [] [ Html.h4 [] [Html.text "Blocks of Resulting Partition:"]
+ WaitingForPartition -> Html.text "waiting..."
+ PartitionResult (Ok res) ->
+ Html.div [Attr.id "blocks"] [ Html.h4 [] [Html.text "Blocks of Resulting Partition:"]
, viewBlocks res
]
- Result (Err res) -> Html.pre [Attr.class "error-message"] [Html.text res]
+ PartitionResult (Err res) -> Html.pre [Attr.class "error-message"] [Html.text res]
+ WaitingForGraph -> Html.text "waiting..."
+ GraphResult (Ok g) -> Html.div [Attr.id "graph"] []
+ GraphResult (Err res) -> Html.pre [Attr.class "error-message"] [Html.text res]
]
-
+
viewBlocks : Blocks -> Html Msg
viewBlocks blocks =
blocks
--
GitLab