diff --git a/src/ArcEditor.purs b/src/ArcEditor.purs new file mode 100644 index 00000000..dad2862b --- /dev/null +++ b/src/ArcEditor.purs @@ -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) + ] + ] + ] + ] + ] + ] diff --git a/src/Model.purs b/src/Model.purs index 4af6018b..63be54bb 100644 --- a/src/Model.purs +++ b/src/Model.purs @@ -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) _ diff --git a/src/PetrinetView.purs b/src/PetrinetView.purs index 406a58c2..e6c5a642 100644 --- a/src/PetrinetView.purs +++ b/src/PetrinetView.purs @@ -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