Skip to content
GitLab
Commit 28d3d054 authored by Hans-Peter Deifel's avatar Hans-Peter Deifel
Browse files

web: Implement graph view

parent 38919229
Hide whitespace changes
Inline Side-by-side
web/assets/custom.css
View file @ 28d3d054
......@@ -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;
}
web/assets/index.html
View file @ 28d3d054
......@@ -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>
web/backend/Main.hs
View file @ 28d3d054
......@@ -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"
web/backend/copar-web.cabal
View file @ 28d3d054
......@@ -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
web/frontend/src/Main.elm
View file @ 28d3d054
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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment