Skip to content

WIP - Create arc editor #32

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 3 commits into
base: master
Choose a base branch
from
Open
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
44 changes: 44 additions & 0 deletions src/ArcEditor.purs
Original file line number Diff line number Diff line change
@@ -0,0 +1,44 @@
module ArcEditor where

import Prelude hiding (div)
import Data.Either (Either(..))
import Data.Foldable (class Foldable, find, elem, foldMap)
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe, isNothing)
import Halogen as H
import Halogen.HTML (HTML, div, text, a, br, hr, form, button, input, textarea, select, option, label, fieldset, legend)
import Halogen.HTML.Events (input_, onClick, onChecked, onValueInput, onValueChange)
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties (classes, disabled, src, width, height, type_, value, rows, placeholder, InputType(..), checked, name)
import Halogen.HTML.Core (ClassName(..))

import Model (ArcQueryF(..), Guard(..), Msg(..))

type ArcEditorFormModel tid =
{ tid :: tid
, guard :: Guard
, label :: String
}

form :: ∀ tid a. Maybe (ArcEditorFormModel tid) -> HTML a ((ArcQueryF tid) Unit)
form mm =
div []
[ div [ classes [ ClassName "field", ClassName "is-horizontal" ] ]
[ div [ classes [ ClassName "field-label" ] ]
[ label [ classes [ ClassName "label" ] ]
[ text "label" ]
]
, div [ classes [ ClassName "field-body" ] ]
[ div [ classes [ ClassName "field" ] ]
[ div [ classes [ ClassName "control" ] ]
[ input [ classes [ ClassName "input" ]
, value (maybe "" (_.label) mm)
, maybe (disabled true)
(\tid -> onValueChange (HE.input (UpdateArcLabel tid)))
(mm <#> _.tid)
]
]
]
]
]
]
7 changes: 7 additions & 0 deletions src/Model.purs
Original file line number Diff line number Diff line change
@@ -21,6 +21,8 @@ data QueryF pid tid a
| FocusPlace pid a
| UpdatePlace (PlaceQueryF pid a)
| UpdateTransition (TransitionQueryF tid a)
| FocusArc tid a
| UpdateArc (ArcQueryF tid a)

data PlaceQueryF pid a
= UpdatePlaceLabel pid String a
@@ -29,6 +31,11 @@ data TransitionQueryF tid a
= UpdateTransitionName tid String a
| UpdateTransitionType tid Typedef a

newtype Guard = Guard String

data ArcQueryF tid a
= UpdateArcLabel tid String a

newtype Typedef = Typedef String

derive instance newtypeTypedef :: Newtype (Typedef) _
33 changes: 28 additions & 5 deletions src/PetrinetView.purs
Original file line number Diff line number Diff line change
@@ -38,13 +38,15 @@ import Arrow as Arrow
import ExampleData as Ex
import ExampleData as Net
import Data.Petrinet.Representation.Dict
import Model (PID, TID, Tokens, Typedef(..), NetObj, NetApi, NetInfoFRow, NetInfoF, QueryF(..), PlaceQueryF(..), TransitionQueryF(..), Msg(..))
import Model (PID, TID, Tokens, Typedef(..), NetObj, NetApi, NetInfoFRow, NetInfoF, QueryF(..), PlaceQueryF(..), TransitionQueryF(..), ArcQueryF(..), Guard(..), Msg(..))
import PlaceEditor as PlaceEditor
import TransitionEditor as TransitionEditor
import ArcEditor as ArcEditor

type StateF pid tid =
{ focusedPlace :: Maybe pid
, focusedTransition :: Maybe tid
, focusedArc :: Maybe tid
, msg :: String
| NetInfoFRow pid tid ()
}
@@ -62,7 +64,7 @@ type ArcModelF tid label pt =
, dest :: pt
, label :: label -- TODO String?
, tid :: tid
, isPost :: Boolean
, isPost :: Boolean -- TODO: `data arcType = Pre | Post`?
, htmlId :: HtmlId
}

@@ -88,6 +90,7 @@ ui initialState' =
, msg: "Please select a net."
, focusedPlace: empty
, focusedTransition: empty
, focusedArc: empty
}

render :: StateF pid tid -> HTML Void (QueryF pid tid Unit)
@@ -118,6 +121,12 @@ ui initialState' =
typ <- Map.lookup tid state.net.transitionTypesDict
pure { tid: tid, label: label, typedef: typ, isWriteable: false }
]
, div [ classes [ ClassName "column" ] ]
[ HH.h1 [ classes [ ClassName "title", ClassName "is-6" ] ] [ HH.text "edit arc" ]
, map UpdateArc <<< ArcEditor.form $ do
tid <- state.focusedArc
pure { tid: tid, guard: Guard "", label: "" }
]
]
]
where
@@ -175,6 +184,19 @@ ui initialState' =
, msg = "Fired transition " <> show tid <> "."
}
pure next
FocusArc tid next -> do
state <- H.get
let focusedArc' = toggleMaybe tid state.focusedArc
H.put $ state { focusedArc = focusedArc'
, msg = (maybe "Focused" (const "Unfocused") state.focusedArc) <>" arc " <> show tid <> "."
}
pure next
UpdateArc (UpdateArcLabel tid label next) -> do
state <- H.get
H.put $ state { net = state.net
, msg = ""
}
pure next

netToSVG :: ∀ tid a. Ord pid => Show pid => Show tid => NetObjF pid tid Tokens Typedef -> Maybe pid -> Maybe tid -> Array (HTML a ((QueryF pid tid) Unit))
netToSVG net focusedPlace focusedTransition =
@@ -210,7 +232,6 @@ ui initialState' =
pure $
SE.g [ SA.class_ $ "css-transition" <> guard isEnabled " enabled"
, SA.id (mkTransitionIdStr tid)
, HE.onClick (HE.input_ (FocusTransition tid))
, HE.onDoubleClick (HE.input_ (if isEnabled then FireTransition tid else FocusTransition tid))
]
(svgPreArcs <> svgPostArcs <> [svgTransitionRect trPos tid])
@@ -226,7 +247,8 @@ ui initialState' =

svgTransitionRect :: ∀ a tid. Show tid => Vec2D -> tid -> HTML a ((QueryF pid tid) Unit)
svgTransitionRect pos tid = SE.rect
[ SA.class_ "css-transition-rect"
[ HE.onClick (HE.input_ (FocusTransition tid))
, SA.class_ "css-transition-rect"
, SA.width transitionWidth
, SA.height transitionHeight
, SA.x (pos.x - transitionWidth / 2.0)
@@ -235,7 +257,8 @@ ui initialState' =

svgArc :: ∀ a pid tid. Show tid => ArcModel tid -> HTML a ((QueryF pid tid) Unit)
svgArc arc =
SE.g [ SA.class_ "css-arc-container" ]
SE.g [ SA.class_ "css-arc-container"
, HE.onClick (HE.input_ (FocusArc arc.tid))]
[ SE.path
[ SA.class_ $ "css-arc " <> if arc.isPost then "css-post-arc" else "css-pre-arc"
, SA.id arc.htmlId -- we refer to this as the path of our animation and label, among others