diff --git a/halogen-diagram-editor/package.json b/halogen-diagram-editor/package.json new file mode 100644 index 00000000..24a42878 --- /dev/null +++ b/halogen-diagram-editor/package.json @@ -0,0 +1,18 @@ +{ + "name": "purescript-halogen-diagram-editor", + "version": "1.0.0", + "description": "Halogen brick diagram editor component", + "author": "Erik Post ", + "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" +} diff --git a/halogen-diagram-editor/src/View/Diagram/Common.purs b/halogen-diagram-editor/src/View/Diagram/Common.purs index 7e8df018..3d958b7b 100644 --- a/halogen-diagram-editor/src/View/Diagram/Common.purs +++ b/halogen-diagram-editor/src/View/Diagram/Common.purs @@ -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 diff --git a/halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs b/halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs index a280104d..6a808c60 100644 --- a/halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs +++ b/halogen-diagram-editor/src/View/Diagram/DiagramEditor.purs @@ -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 @@ -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 @@ -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 @@ -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 @@ -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 diff --git a/halogen-diagram-editor/src/View/Diagram/Model.purs b/halogen-diagram-editor/src/View/Diagram/Model.purs index 7c8987d6..7a84482b 100644 --- a/halogen-diagram-editor/src/View/Diagram/Model.purs +++ b/halogen-diagram-editor/src/View/Diagram/Model.purs @@ -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) @@ -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 = diff --git a/halogen-diagram-editor/src/View/Diagram/Update.purs b/halogen-diagram-editor/src/View/Diagram/Update.purs index e51b8db8..31232855 100644 --- a/halogen-diagram-editor/src/View/Diagram/Update.purs +++ b/halogen-diagram-editor/src/View/Diagram/Update.purs @@ -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 diff --git a/halogen-diagram-editor/src/View/Diagram/View.purs b/halogen-diagram-editor/src/View/Diagram/View.purs index 265a54e2..f7950af8 100644 --- a/halogen-diagram-editor/src/View/Diagram/View.purs +++ b/halogen-diagram-editor/src/View/Diagram/View.purs @@ -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 diff --git a/studio/src/View/Studio.purs b/studio/src/View/Studio.purs index d3180045..482132c3 100644 --- a/studio/src/View/Studio.purs +++ b/studio/src/View/Studio.purs @@ -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) @@ -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) @@ -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 diff --git a/studio/src/View/Studio/Model.purs b/studio/src/View/Studio/Model.purs index 9751b8ea..bede66e6 100644 --- a/studio/src/View/Studio/Model.purs +++ b/studio/src/View/Studio/Model.purs @@ -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) @@ -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 @@ -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