Skip to content
Merged
Show file tree
Hide file tree
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
18 changes: 18 additions & 0 deletions halogen-diagram-editor/package.json
Original file line number Diff line number Diff line change
@@ -0,0 +1,18 @@
{
"name": "purescript-halogen-diagram-editor",
"version": "1.0.0",
"description": "Halogen brick diagram editor component",
"author": "Erik Post <erik@shinsetsu.nl>",
"main": "index.js",
"scripts": {
"postinstall": "spago install",
"build": "spago build -- --censor-codes=ImplicitImport,ImplicitQualifiedImport,HidingImport",
"watch": "spago build --watch -- --censor-codes=ImplicitImport,ImplicitQualifiedImport,HidingImport"
},
"devDependencies": {
"purescript": "^0.13.3",
"purescript-psa": "^0.7.3",
"spago": "^0.9.0"
},
"license": "ISC"
}
2 changes: 1 addition & 1 deletion halogen-diagram-editor/src/View/Diagram/Common.purs
Original file line number Diff line number Diff line change
@@ -1,7 +1,7 @@
module View.Diagram.Common where

import Prelude
import Data.Int (toNumber, floor, round)
import Data.Int (toNumber, round)
import Halogen.HTML.Properties as HP
import Halogen.HTML.Core as HC

Expand Down
18 changes: 11 additions & 7 deletions halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ import Prelude hiding (div)

import Data.Array (snoc, length)
import Data.Maybe (Maybe(..), maybe)
import Data.Tuple.Nested (type (/\), (/\))
import Data.Tuple.Nested ((/\))
import Data.Vec3 (Vec3, vec3, _x, _y, _z)
import Effect.Aff.Class (class MonadAff)
import Halogen as H
Expand All @@ -21,7 +21,7 @@ import Web.UIEvent.KeyboardEvent (code, toEvent)

import View.Diagram.Common (classesWithNames)
import View.Diagram.Model (DragStart(..), Operators)
import View.Diagram.Update (Action(..), MouseMsg(..), Msg(..), State, evalModel)
import View.Diagram.Update (Action(..), MouseMsg(..), Msg(..), DirtyState(Clean, Dirty), State, evalModel)
import View.Diagram.View as View
import View.Diagram.Inspector as Inspector

Expand Down Expand Up @@ -68,14 +68,13 @@ ui = H.mkComponent { initialState, render, eval: mkEval $ defaultEval {
let id = length ops
let newOp = { identifier: "new" <> show id, pos: m.cursorPos + vec3 1 0 7, label: "new" <> show id }
H.modify_ \st -> st { model = m { cursorPos = m.cursorPos + vec3 0 1 0 } }
handleAction $ UpdateDiagram (ops `snoc` newOp)
H.raise $ OperatorsChanged (ops `snoc` newOp)

MoveCursor delta -> do
m <- H.get <#> _.model
let { cursorPos, config: { scale, width, height } } = m
let cursorPos' = clamp2d (width/scale+1) (height/scale+1) (cursorPos + delta)
H.modify_ \st -> st { model = m { cursorPos = cursorPos' } }
H.raise CursorMoved

KeyboardAction k -> do
H.liftEffect $ preventDefault $ toEvent k
Expand All @@ -91,9 +90,14 @@ ui = H.mkComponent { initialState, render, eval: mkEval $ defaultEval {

MouseAction msg -> do
state <- H.get
let state' = state { model = evalModel msg state.model }
let (opsChanged /\ model') = evalModel msg state.model
state' = state { model = model' }

isOperatorClicked = case msg of
case opsChanged of
Dirty -> H.raise (OperatorsChanged model'.ops)
Clean -> pure unit

let isOperatorClicked = case msg of
MouseUp _ -> true
_ -> false

Expand All @@ -108,7 +112,7 @@ ui = H.mkComponent { initialState, render, eval: mkEval $ defaultEval {

maybe (pure unit) (H.raise <<< OperatorClicked) clickedOperatorId

UpdateDiagram ops ->
UpdateDiagram ops -> do
H.modify_ \state -> state { model = state.model { ops = ops } }

Initialize -> do
Expand Down
4 changes: 2 additions & 2 deletions halogen-diagram-editor/src/View/Diagram/Model.purs
Original file line number Diff line number Diff line change
@@ -1,9 +1,9 @@
module View.Diagram.Model where

import Data.Maybe
import Data.Tuple.Nested (type (/\))
import Prelude

import Data.Tuple.Nested (type (/\), (/\))
import Data.Vec3 (Vec3, Vec2, vec3, _x, _y)

import View.Diagram.Common (snap)
Expand All @@ -13,7 +13,7 @@ type DiagramInfo =
, ops :: Array Operator
}

-- must be unique; problematic, want to lenses instead
-- must be unique; problematic, want to use lenses instead
type OperatorId = String

type Operator =
Expand Down
71 changes: 39 additions & 32 deletions halogen-diagram-editor/src/View/Diagram/Update.purs
Original file line number Diff line number Diff line change
Expand Up @@ -34,43 +34,50 @@ data MouseMsg

data Msg
= OperatorClicked OperatorId
| CursorMoved
| OperatorsChanged (Array Operator)

data DirtyState = Clean | Dirty

--------------------------------------------------------------------------------

evalModel :: MouseMsg -> Model -> Model
-- | The `DirtyState` in the result indicates if any ops were modified.
evalModel :: MouseMsg -> Model -> DirtyState /\ Model
evalModel msg model = case msg of
MouseIsOut _ -> model { mouseOver = Nothing }
MouseIsOver x k -> model { mouseOver = Just (x /\ k) }
MousePos p -> model { mousePos = p }
MouseDown p -> model { mousePos = p
, mousePressed = true
, dragStart = case model.mouseOver of
Nothing -> DragStartedOnBackground model.mousePos
Just (op /\ opPos) -> DragStartedOnOperator model.mousePos op opPos
}
MouseUp p -> (dropGhost model) { mousePos = p
, mousePressed = false
, dragStart = DragNotStarted
}
MouseIsOut _ -> Clean /\ model { mouseOver = Nothing }
MouseIsOver x k -> Clean /\ model { mouseOver = Just (x /\ k) }
MousePos p -> Clean /\ model { mousePos = p }
MouseDown p -> Clean /\ model { mousePos = p
, mousePressed = true
, dragStart = case model.mouseOver of
Nothing -> DragStartedOnBackground model.mousePos
Just (op /\ opPos) -> DragStartedOnOperator model.mousePos op opPos
}
MouseUp p -> opsModified /\ model' { mousePos = p
, mousePressed = false
, dragStart = DragNotStarted
}
where
opsModified /\ model' = dropGhost model

--------------------------------------------------------------------------------

dropGhost :: Model -> Model
-- | The `DirtyState` in the result indicates if any ops were modified.
dropGhost :: Model -> DirtyState /\ Model
dropGhost model = case model.dragStart of
DragStartedOnOperator _ op _ ->
let scale = model.config.scale
dd = dragDelta model
ddScreen = snap scale <$> dd
ddModel = (_/scale) <$> ddScreen
opxyw = op.pos - ddModel
(cw /\ ch) = model.config.width /\ model.config.height
isValid = isPositive && isBounded
isPositive = (_x opxyw >= zero) && (_y opxyw >= zero)
isBounded = (_x opxyw < (cw / scale)) && (_y opxyw < (ch / scale))
-- TODO ^ add condition for w
(ox /\ ow) = if _z opxyw > zero then _x opxyw /\ _z opxyw else (_x opxyw + _z opxyw) /\ (- _z opxyw)
modOp o = o { pos = vec3 ox (_y opxyw) ow }
newOps = modifyOperator op.identifier modOp model.ops
in if isValid then model { ops = newOps } else model
_ -> model
DragStartedOnOperator _ op _ -> if isValid then Dirty /\ model { ops = newOps }
else Clean /\ model
where
scale = model.config.scale
dd = dragDelta model
ddScreen = snap scale <$> dd
ddModel = (_/scale) <$> ddScreen
opxyw = op.pos - ddModel
(cw /\ ch) = model.config.width /\ model.config.height
isValid = isPositive && isBounded
isPositive = (_x opxyw >= zero) && (_y opxyw >= zero)
isBounded = (_x opxyw < (cw / scale)) && (_y opxyw < (ch / scale))
-- TODO ^ add condition for w
(ox /\ ow) = if _z opxyw > zero then _x opxyw /\ _z opxyw else (_x opxyw + _z opxyw) /\ (- _z opxyw)
modOp o = o { pos = vec3 ox (_y opxyw) ow }
newOps = modifyOperator op.identifier modOp model.ops
_ -> Clean /\ model
3 changes: 1 addition & 2 deletions halogen-diagram-editor/src/View/Diagram/View.purs
Original file line number Diff line number Diff line change
Expand Up @@ -3,10 +3,9 @@ module View.Diagram.View where
import Prelude
import Data.Array (snoc)
import Data.Foldable (elem)
import Data.Int (toNumber, fromStringAs, hexadecimal)
import Data.Int (toNumber)
import Data.Maybe (Maybe(..), maybe)
import Data.Monoid (guard)
import Data.Tuple.Nested (type (/\), (/\))
import Data.Ord (abs)
import Data.Vec3 (Vec3, Vec2, _x, _y, _z, vec3)
import Halogen as H
Expand Down
18 changes: 14 additions & 4 deletions studio/src/View/Studio.purs
Original file line number Diff line number Diff line change
Expand Up @@ -7,7 +7,7 @@ import Control.Coroutine (Consumer, Producer, Process, runProcess, consumer, con
import Data.Array (cons)
import Data.AdjacencySpace as AdjacencySpace
import Data.Either (either)
import Data.Maybe (Maybe(..), maybe)
import Data.Maybe (Maybe(..), maybe, fromMaybe)
import Effect.Exception (try)
import Effect.Aff.Class (class MonadAff)
import Effect.Console (log)
Expand All @@ -24,7 +24,8 @@ import Statebox.Core.Transaction (HashTx)
import Statebox.Core.Transaction.Codec (DecodingError(..))
import View.Diagram.Update as DiagramEditor
import View.Petrinet.Model (Msg(NetUpdated))
import View.Studio.Model (Action(..), State, fromPNPROProject)
import View.Model (Project)
import View.Studio.Model (Action(..), State, fromPNPROProject, modifyProject, modifyDiagramInfo)
import View.Studio.Model.Route (Route, RouteF(..), NodeIdent(..))
import View.Studio.View (render, ChildSlots)

Expand Down Expand Up @@ -112,8 +113,17 @@ ui =
_ -> Nothing
maybe (pure unit) (handleAction <<< SelectRoute) newRouteMaybe

HandleDiagramEditorMsg (DiagramEditor.CursorMoved) -> do
pure unit
HandleDiagramEditorMsg (DiagramEditor.OperatorsChanged ops) -> do
state <- H.get
let
projectsUpdatedMaybe :: Maybe (Array Project)
projectsUpdatedMaybe = case state.route of
Diagram pname dname _ ->
modifyProject pname (\p ->
p { diagrams = fromMaybe p.diagrams (modifyDiagramInfo dname (_ {ops = ops}) p.diagrams) }
) state.projects
_ -> Nothing
maybe (pure unit) (\projects -> H.modify_ (_ { projects = projects }) ) projectsUpdatedMaybe

HandlePetrinetEditorMsg NetUpdated -> do
pure unit
12 changes: 11 additions & 1 deletion studio/src/View/Studio/Model.purs
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ module View.Studio.Model where

import Prelude
import Affjax (URL) -- TODO introduce URL alias in Client so we can abstract Affjax away
import Data.Array (index)
import Data.Array (index, findIndex, modifyAt)
import Data.AdjacencySpace as AdjacencySpace
import Data.AdjacencySpace (AdjacencySpace)
import Data.Bifunctor (bimap)
Expand Down Expand Up @@ -84,6 +84,11 @@ resolveRoute route {projects, hashSpace} = case route of
findProject :: Array Project -> ProjectName -> Maybe Project
findProject projects projectName = find (\p -> p.name == projectName) projects

modifyProject :: ProjectName -> (Project -> Project) -> Array Project -> Maybe (Array Project)
modifyProject projectName fn projects = do
ix <- findIndex (\p -> p.name == projectName) projects
modifyAt ix fn projects

findNetInfo :: Project -> NetName -> Maybe NetInfo
findNetInfo project netName = find (\n -> n.name == netName) project.nets

Expand All @@ -94,6 +99,11 @@ findNetInfoWithTypesAndRoles project netName =
findDiagramInfo :: Project -> DiagramName -> Maybe DiagramInfo
findDiagramInfo project diagramName = find (\d -> d.name == diagramName) project.diagrams

modifyDiagramInfo :: DiagramName -> (DiagramInfo -> DiagramInfo) -> Array DiagramInfo -> Maybe (Array DiagramInfo)
modifyDiagramInfo diagramName fn diagrams = do
ix <- findIndex (\d -> d.name == diagramName) diagrams
modifyAt ix fn diagrams

findWiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe WiringTx
findWiringTx hashSpace wiringHash = preview _wiringTx =<< AdjacencySpace.lookup wiringHash hashSpace

Expand Down