Skip to content

Commit be16565

Browse files
clayratepost
clayrat
authored and
epost
committed
halogen-diagram-editor: Persist updated diagrams in memory. (#286)
* halogen-diagram-editor: fix endless loop when a diagram changes. #267 * halogen-diagram-editor: prettify #267 * halogen-diagram-editor: Add package.json so we can build. #286 * halogen-diagram-editor: Rename OpsChanged to OperatorsChanged. #267 * halogen-diagram-editor: Some comments and syntactic noodling around diagram updates. #267 * halogen-diagram-editor: Replace 'opsChanged' Boolean by DirtyState. #267 * halogen-diagram-editor: Add another DirtyState comment. #267
1 parent 1bbeca0 commit be16565

File tree

8 files changed

+97
-49
lines changed

8 files changed

+97
-49
lines changed

‎halogen-diagram-editor/package.json‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,18 @@
1+
{
2+
"name": "purescript-halogen-diagram-editor",
3+
"version": "1.0.0",
4+
"description": "Halogen brick diagram editor component",
5+
"author": "Erik Post <erik@shinsetsu.nl>",
6+
"main": "index.js",
7+
"scripts": {
8+
"postinstall": "spago install",
9+
"build": "spago build -- --censor-codes=ImplicitImport,ImplicitQualifiedImport,HidingImport",
10+
"watch": "spago build --watch -- --censor-codes=ImplicitImport,ImplicitQualifiedImport,HidingImport"
11+
},
12+
"devDependencies": {
13+
"purescript": "^0.13.3",
14+
"purescript-psa": "^0.7.3",
15+
"spago": "^0.9.0"
16+
},
17+
"license": "ISC"
18+
}

‎halogen-diagram-editor/src/View/Diagram/Common.purs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,7 @@
11
module View.Diagram.Common where
22

33
import Prelude
4-
import Data.Int (toNumber, floor, round)
4+
import Data.Int (toNumber, round)
55
import Halogen.HTML.Properties as HP
66
import Halogen.HTML.Core as HC
77

‎halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs‎

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ import Prelude hiding (div)
44

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

2222
import View.Diagram.Common (classesWithNames)
2323
import View.Diagram.Model (DragStart(..), Operators)
24-
import View.Diagram.Update (Action(..), MouseMsg(..), Msg(..), State, evalModel)
24+
import View.Diagram.Update (Action(..), MouseMsg(..), Msg(..), DirtyState(Clean, Dirty), State, evalModel)
2525
import View.Diagram.View as View
2626
import View.Diagram.Inspector as Inspector
2727

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

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

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

9291
MouseAction msg -> do
9392
state <- H.get
94-
let state' = state { model = evalModel msg state.model }
93+
let (opsChanged /\ model') = evalModel msg state.model
94+
state' = state { model = model' }
9595

96-
isOperatorClicked = case msg of
96+
case opsChanged of
97+
Dirty -> H.raise (OperatorsChanged model'.ops)
98+
Clean -> pure unit
99+
100+
let isOperatorClicked = case msg of
97101
MouseUp _ -> true
98102
_ -> false
99103

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

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

111-
UpdateDiagram ops ->
115+
UpdateDiagram ops -> do
112116
H.modify_ \state -> state { model = state.model { ops = ops } }
113117

114118
Initialize -> do

‎halogen-diagram-editor/src/View/Diagram/Model.purs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,9 @@
11
module View.Diagram.Model where
22

33
import Data.Maybe
4+
import Data.Tuple.Nested (type (/\))
45
import Prelude
56

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

99
import View.Diagram.Common (snap)
@@ -13,7 +13,7 @@ type DiagramInfo =
1313
, ops :: Array Operator
1414
}
1515

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

1919
type Operator =

‎halogen-diagram-editor/src/View/Diagram/Update.purs‎

Lines changed: 39 additions & 32 deletions
Original file line numberDiff line numberDiff line change
@@ -34,43 +34,50 @@ data MouseMsg
3434

3535
data Msg
3636
= OperatorClicked OperatorId
37-
| CursorMoved
37+
| OperatorsChanged (Array Operator)
38+
39+
data DirtyState = Clean | Dirty
3840

3941
--------------------------------------------------------------------------------
4042

41-
evalModel :: MouseMsg -> Model -> Model
43+
-- | The `DirtyState` in the result indicates if any ops were modified.
44+
evalModel :: MouseMsg -> Model -> DirtyState /\ Model
4245
evalModel msg model = case msg of
43-
MouseIsOut _ -> model { mouseOver = Nothing }
44-
MouseIsOver x k -> model { mouseOver = Just (x /\ k) }
45-
MousePos p -> model { mousePos = p }
46-
MouseDown p -> model { mousePos = p
47-
, mousePressed = true
48-
, dragStart = case model.mouseOver of
49-
Nothing -> DragStartedOnBackground model.mousePos
50-
Just (op /\ opPos) -> DragStartedOnOperator model.mousePos op opPos
51-
}
52-
MouseUp p -> (dropGhost model) { mousePos = p
53-
, mousePressed = false
54-
, dragStart = DragNotStarted
55-
}
46+
MouseIsOut _ -> Clean /\ model { mouseOver = Nothing }
47+
MouseIsOver x k -> Clean /\ model { mouseOver = Just (x /\ k) }
48+
MousePos p -> Clean /\ model { mousePos = p }
49+
MouseDown p -> Clean /\ model { mousePos = p
50+
, mousePressed = true
51+
, dragStart = case model.mouseOver of
52+
Nothing -> DragStartedOnBackground model.mousePos
53+
Just (op /\ opPos) -> DragStartedOnOperator model.mousePos op opPos
54+
}
55+
MouseUp p -> opsModified /\ model' { mousePos = p
56+
, mousePressed = false
57+
, dragStart = DragNotStarted
58+
}
59+
where
60+
opsModified /\ model' = dropGhost model
5661

5762
--------------------------------------------------------------------------------
5863

59-
dropGhost :: Model -> Model
64+
-- | The `DirtyState` in the result indicates if any ops were modified.
65+
dropGhost :: Model -> DirtyState /\ Model
6066
dropGhost model = case model.dragStart of
61-
DragStartedOnOperator _ op _ ->
62-
let scale = model.config.scale
63-
dd = dragDelta model
64-
ddScreen = snap scale <$> dd
65-
ddModel = (_/scale) <$> ddScreen
66-
opxyw = op.pos - ddModel
67-
(cw /\ ch) = model.config.width /\ model.config.height
68-
isValid = isPositive && isBounded
69-
isPositive = (_x opxyw >= zero) && (_y opxyw >= zero)
70-
isBounded = (_x opxyw < (cw / scale)) && (_y opxyw < (ch / scale))
71-
-- TODO ^ add condition for w
72-
(ox /\ ow) = if _z opxyw > zero then _x opxyw /\ _z opxyw else (_x opxyw + _z opxyw) /\ (- _z opxyw)
73-
modOp o = o { pos = vec3 ox (_y opxyw) ow }
74-
newOps = modifyOperator op.identifier modOp model.ops
75-
in if isValid then model { ops = newOps } else model
76-
_ -> model
67+
DragStartedOnOperator _ op _ -> if isValid then Dirty /\ model { ops = newOps }
68+
else Clean /\ model
69+
where
70+
scale = model.config.scale
71+
dd = dragDelta model
72+
ddScreen = snap scale <$> dd
73+
ddModel = (_/scale) <$> ddScreen
74+
opxyw = op.pos - ddModel
75+
(cw /\ ch) = model.config.width /\ model.config.height
76+
isValid = isPositive && isBounded
77+
isPositive = (_x opxyw >= zero) && (_y opxyw >= zero)
78+
isBounded = (_x opxyw < (cw / scale)) && (_y opxyw < (ch / scale))
79+
-- TODO ^ add condition for w
80+
(ox /\ ow) = if _z opxyw > zero then _x opxyw /\ _z opxyw else (_x opxyw + _z opxyw) /\ (- _z opxyw)
81+
modOp o = o { pos = vec3 ox (_y opxyw) ow }
82+
newOps = modifyOperator op.identifier modOp model.ops
83+
_ -> Clean /\ model

‎halogen-diagram-editor/src/View/Diagram/View.purs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3,10 +3,9 @@ module View.Diagram.View where
33
import Prelude
44
import Data.Array (snoc)
55
import Data.Foldable (elem)
6-
import Data.Int (toNumber, fromStringAs, hexadecimal)
6+
import Data.Int (toNumber)
77
import Data.Maybe (Maybe(..), maybe)
88
import Data.Monoid (guard)
9-
import Data.Tuple.Nested (type (/\), (/\))
109
import Data.Ord (abs)
1110
import Data.Vec3 (Vec3, Vec2, _x, _y, _z, vec3)
1211
import Halogen as H

‎studio/src/View/Studio.purs‎

Lines changed: 14 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,7 @@ import Control.Coroutine (Consumer, Producer, Process, runProcess, consumer, con
77
import Data.Array (cons)
88
import Data.AdjacencySpace as AdjacencySpace
99
import Data.Either (either)
10-
import Data.Maybe (Maybe(..), maybe)
10+
import Data.Maybe (Maybe(..), maybe, fromMaybe)
1111
import Effect.Exception (try)
1212
import Effect.Aff.Class (class MonadAff)
1313
import Effect.Console (log)
@@ -24,7 +24,8 @@ import Statebox.Core.Transaction (HashTx)
2424
import Statebox.Core.Transaction.Codec (DecodingError(..))
2525
import View.Diagram.Update as DiagramEditor
2626
import View.Petrinet.Model (Msg(NetUpdated))
27-
import View.Studio.Model (Action(..), State, fromPNPROProject)
27+
import View.Model (Project)
28+
import View.Studio.Model (Action(..), State, fromPNPROProject, modifyProject, modifyDiagramInfo)
2829
import View.Studio.Model.Route (Route, RouteF(..), NodeIdent(..))
2930
import View.Studio.View (render, ChildSlots)
3031

@@ -112,8 +113,17 @@ ui =
112113
_ -> Nothing
113114
maybe (pure unit) (handleAction <<< SelectRoute) newRouteMaybe
114115

115-
HandleDiagramEditorMsg (DiagramEditor.CursorMoved) -> do
116-
pure unit
116+
HandleDiagramEditorMsg (DiagramEditor.OperatorsChanged ops) -> do
117+
state <- H.get
118+
let
119+
projectsUpdatedMaybe :: Maybe (Array Project)
120+
projectsUpdatedMaybe = case state.route of
121+
Diagram pname dname _ ->
122+
modifyProject pname (\p ->
123+
p { diagrams = fromMaybe p.diagrams (modifyDiagramInfo dname (_ {ops = ops}) p.diagrams) }
124+
) state.projects
125+
_ -> Nothing
126+
maybe (pure unit) (\projects -> H.modify_ (_ { projects = projects }) ) projectsUpdatedMaybe
117127

118128
HandlePetrinetEditorMsg NetUpdated -> do
119129
pure unit

‎studio/src/View/Studio/Model.purs‎

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ module View.Studio.Model where
22

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

87+
modifyProject :: ProjectName -> (Project -> Project) -> Array Project -> Maybe (Array Project)
88+
modifyProject projectName fn projects = do
89+
ix <- findIndex (\p -> p.name == projectName) projects
90+
modifyAt ix fn projects
91+
8792
findNetInfo :: Project -> NetName -> Maybe NetInfo
8893
findNetInfo project netName = find (\n -> n.name == netName) project.nets
8994

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

102+
modifyDiagramInfo :: DiagramName -> (DiagramInfo -> DiagramInfo) -> Array DiagramInfo -> Maybe (Array DiagramInfo)
103+
modifyDiagramInfo diagramName fn diagrams = do
104+
ix <- findIndex (\d -> d.name == diagramName) diagrams
105+
modifyAt ix fn diagrams
106+
97107
findWiringTx :: AdjacencySpace HashStr TxSum -> HashStr -> Maybe WiringTx
98108
findWiringTx hashSpace wiringHash = preview _wiringTx =<< AdjacencySpace.lookup wiringHash hashSpace
99109

0 commit comments

Comments
 (0)