mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
757 lines
24 KiB
Haskell
757 lines
24 KiB
Haskell
-- This file is formatted with Ormolu
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
-- | This module is the core of the GUI model and control. This module
|
|
-- does not interact with GUI libraries.
|
|
module GuiInternals
|
|
( Inputs (..),
|
|
emptyInputs,
|
|
AppState (..),
|
|
emptyAppState,
|
|
MouseButton (..),
|
|
KeyEvent (..),
|
|
renderCairo,
|
|
updateBackground,
|
|
backgroundPress,
|
|
keyPress,
|
|
keyRelease,
|
|
scroll,
|
|
step,
|
|
)
|
|
where
|
|
|
|
import Control.Monad.Trans.Reader (runReaderT)
|
|
import Data.Coerce (Coercible)
|
|
import Data.Foldable (traverse_)
|
|
import Data.GI.Base (withManagedPtr)
|
|
import Data.IORef (IORef, modifyIORef', readIORef, writeIORef)
|
|
import qualified Data.IntMap.Strict as IntMap
|
|
import Data.List (find)
|
|
-- import Debug.Trace (trace)
|
|
|
|
import Data.Maybe (isNothing)
|
|
import Data.Text (Text)
|
|
import Data.Time.Clock.System (SystemTime (MkSystemTime))
|
|
import qualified Data.Tuple.Extra as Tuple
|
|
import Foreign.Ptr (castPtr)
|
|
import qualified GI.Cairo (Context (..))
|
|
import qualified Graphics.Rendering.Cairo as Cairo
|
|
import Graphics.Rendering.Cairo.Internal (Render (runRender))
|
|
import Graphics.Rendering.Cairo.Types (Cairo (Cairo))
|
|
|
|
-- Constants
|
|
minimumScale :: Double
|
|
minimumScale = 0.1
|
|
|
|
-- Types
|
|
|
|
-- | An Enum of mouse buttons, so order is important!
|
|
data MouseButton
|
|
= LeftMouseButton
|
|
| MiddleMouseButton
|
|
| RightMouseButton
|
|
| UnknownMouseButton
|
|
deriving (Eq, Ord, Enum, Bounded, Show)
|
|
|
|
-- | What action should be taken when you press a key?
|
|
data KeyEvent
|
|
= UndoKey
|
|
| AbortKey
|
|
| TranslateKey
|
|
| UnknownKey Text
|
|
|
|
-- | This is not an enmum so that new types of nodes can be created at
|
|
-- runtime. Everything of type (Double, Double) is either (width,
|
|
-- height) or (x, y).
|
|
data NodeType = NodeType
|
|
{ _ntName :: !String,
|
|
_ntNumInitialPorts :: !Int,
|
|
-- | Returns which port was clicked on. If no port was clicked it
|
|
-- returns Nothing.
|
|
_ntPortClicked ::
|
|
!( (Double, Double) -> -- (x, y) in the node's coordinates.
|
|
Element -> -- Which element was clicked
|
|
Maybe Int
|
|
),
|
|
_ntDraw :: !(Transform -> (Int, Element) -> Render ()),
|
|
-- | Given the port number, return the location of that port in
|
|
-- the node's coordinates.
|
|
_ntPortLocations :: !(Int -> (Double, Double)),
|
|
-- | (x, y) position of the center of the handle.
|
|
_ntHandleLocation :: !(Double, Double),
|
|
-- ? Should the argument be Element instead?
|
|
|
|
-- | Given the number of ports, return the size of the node.
|
|
_ntSize :: !(Int -> (Double, Double))
|
|
}
|
|
|
|
-- | A simple 2d transformation. See transform below for
|
|
-- details.
|
|
data Transform = Transform
|
|
{ -- | Controls scaling. This is a scale factor, so the size of
|
|
-- visual elements are multiplied by this number. Thus a value of
|
|
-- one is no scale, values greater than 1 scales in, and values
|
|
-- between 0 and 1 scales out. Negative values result in undefined
|
|
-- behavior, although it would be cool if negative values
|
|
-- produced a flip across both the X and Y axes.
|
|
_tScale :: !Double,
|
|
-- | (x, y)
|
|
_tTranslate :: !(Double, Double)
|
|
}
|
|
|
|
-- TODO Add quick check tests that transform and unTransform are inverses
|
|
transform :: Transform -> (Double, Double) -> (Double, Double)
|
|
transform (Transform scale (deltaX, deltaY)) (x, y) =
|
|
( x * scale + deltaX,
|
|
y * scale + deltaY
|
|
)
|
|
|
|
unTransform :: Transform -> (Double, Double) -> (Double, Double)
|
|
unTransform (Transform scale (deltaX, deltaY)) (transformedX, transformedY) =
|
|
( (transformedX - deltaX) / scale,
|
|
(transformedY - deltaY) / scale
|
|
)
|
|
|
|
windowToElementCoordinates :: AppState -> (Double, Double) -> (Double, Double)
|
|
windowToElementCoordinates state = unTransform (_asTransform state)
|
|
|
|
newtype ElemId = ElemId {_unElemId :: Int} deriving (Show, Eq, Ord, Num)
|
|
|
|
-- | A graphical element that can be clicked
|
|
data Element = Element
|
|
{ -- | (x, y) of top left corner. These values are in Element
|
|
-- coordinates. Use the (transform _asTransform) function to
|
|
-- convert these to window coordinates and (unTransform
|
|
-- _asTransform) to convert window coordinates to _elPosition.
|
|
_elPosition :: !(Double, Double),
|
|
-- | Depth. Higher values are drawn on top
|
|
-- _elZ is currently ignored
|
|
_elZ :: !Int,
|
|
_elType :: !NodeType,
|
|
_elNumPorts :: !Int
|
|
}
|
|
|
|
-- | When the translation key is first pressed, these values contain
|
|
-- the mouse position and (_tTranslate . _asTransform) at that moment.
|
|
data Panning = Panning
|
|
{ _panMouse :: !(Double, Double),
|
|
_panTranslation :: !(Double, Double)
|
|
}
|
|
deriving (Eq, Ord, Show)
|
|
|
|
-- | A specific port in a node.
|
|
data Port = Port
|
|
{ -- | The node this port is in.
|
|
_pNode :: ElemId,
|
|
-- | The port number of the port in the node.
|
|
_pPort :: Int
|
|
}
|
|
|
|
data Inputs = Inputs
|
|
{ -- | Raw mouse x and y position in window coordinates.
|
|
_inMouseXandY :: !(Double, Double),
|
|
_inTime :: !SystemTime,
|
|
_inPrevTime :: !SystemTime,
|
|
_inEvents :: ![InputEvent],
|
|
-- | If Something, then a translation is occuring.
|
|
_inTranslation :: !(Maybe Panning)
|
|
}
|
|
|
|
-- TODO Consider extracting History and UndoPosition into their own "object".
|
|
data AppState = AppState
|
|
{ -- | This is a key for _asElements
|
|
_asMovingNode :: !(Maybe ElemId),
|
|
-- TODO _asEdges is a set, so consider using a set data structure here.
|
|
|
|
-- | The connections between nodes. Currently the edges do not have a direction.
|
|
_asEdges :: ![(Port, Port)],
|
|
-- | Iff Just, an edge is currently being draw where the ElemId is
|
|
-- one end of the edge.
|
|
_asCurrentEdge :: !(Maybe Port),
|
|
_asElements :: !(IntMap.IntMap Element),
|
|
-- | FPS rounded down to nearest hundred if over 200 fps.
|
|
_asFPSr :: !Double,
|
|
-- | A full history of the state of the app. Use addHistoryEvent
|
|
-- to add new HistoryEvents, do not add events directly.
|
|
_asHistory :: ![Undoable HistoryEvent],
|
|
-- | A pointer into _asHistory. The undo command pops this
|
|
-- stack, undos the HistoryEvent, and pushes the inverse of the
|
|
-- popped HistoryEvent onto _asHistory.
|
|
_asUndoPosition :: ![Undoable HistoryEvent],
|
|
-- | The biggest ElemId used so far in the program. Not updated by undo.
|
|
_asBiggestID :: !ElemId,
|
|
-- | Controls scalaing (aka. zooming) and translation (aka. panning)
|
|
_asTransform :: !Transform
|
|
}
|
|
|
|
data InputEvent
|
|
= -- | Which node was clicked and the relative click position within a node.
|
|
ClickOnNode
|
|
!ElemId
|
|
!(Double, Double) -- relative mouse position
|
|
| AddNode !(Double, Double) -- where to add the node
|
|
| -- | Undo the last action.
|
|
UndoEvent
|
|
| -- | Abort the current command (like C-g in Emacs).
|
|
AbortEvent
|
|
| -- | The scale factor is multiplied by this number.
|
|
ScaleAdjustEvent !Double
|
|
|
|
data Undoable a = Do !a | Undo !a
|
|
|
|
-- NodeType instances
|
|
|
|
handleWidth :: Double
|
|
handleWidth = 50
|
|
|
|
portWidth :: Double
|
|
portWidth = 30
|
|
|
|
applyNodeHeight :: Double
|
|
applyNodeHeight = 30
|
|
|
|
-- | Draw an apply node. This function's type will probably change
|
|
-- since some of this could be done in drawNode.
|
|
drawApply :: Transform -> (Int, Element) -> Render ()
|
|
drawApply transformation (elemId, Element {..}) = do
|
|
-- TODO See if there's a way to scale the entire Cairo drawing.
|
|
let (x, y) = transform transformation _elPosition
|
|
scale = _tScale transformation
|
|
scaledPortWidth = scale * portWidth
|
|
scaledHeight = scale * applyNodeHeight
|
|
scaledHandleWidth = scale * handleWidth
|
|
drawPort portNum =
|
|
Cairo.rectangle
|
|
(x + scaledHandleWidth + scaledPortWidth * fromIntegral portNum)
|
|
y
|
|
scaledPortWidth
|
|
scaledHeight
|
|
|
|
Cairo.setSourceRGB 1 1 1
|
|
Cairo.setLineWidth (3 * scale)
|
|
-- Draw the handle
|
|
Cairo.rectangle x y scaledHandleWidth scaledHeight
|
|
Cairo.moveTo (x + 5) (y + snd (_ntHandleLocation _elType))
|
|
Cairo.showText (show elemId <> " " <> _ntName _elType)
|
|
Cairo.stroke
|
|
Cairo.setSourceRGB 1 0 0
|
|
traverse_ drawPort [0 .. (_elNumPorts -1)]
|
|
Cairo.stroke
|
|
|
|
applyPortClicked :: (Double, Double) -> Element -> Maybe Int
|
|
applyPortClicked (x, _) Element {_elNumPorts} =
|
|
let rectClicked = floor ((x - handleWidth) / portWidth)
|
|
in if x <= handleWidth
|
|
then Nothing
|
|
else Just rectClicked
|
|
|
|
applyPortLocations :: Int -> (Double, Double)
|
|
applyPortLocations port =
|
|
( handleWidth + (portWidth / 2) + (fromIntegral port * portWidth),
|
|
applyNodeHeight / 2
|
|
)
|
|
|
|
applySize :: Int -> (Double, Double)
|
|
applySize numPorts =
|
|
( handleWidth + portWidth * fromIntegral numPorts,
|
|
applyNodeHeight
|
|
)
|
|
|
|
apply :: NodeType
|
|
apply =
|
|
NodeType
|
|
{ _ntName = "apply",
|
|
_ntNumInitialPorts = 2,
|
|
_ntPortClicked = applyPortClicked,
|
|
_ntDraw = drawApply,
|
|
_ntPortLocations = applyPortLocations,
|
|
_ntHandleLocation = (handleWidth / 2, applyNodeHeight / 2),
|
|
_ntSize = applySize
|
|
}
|
|
|
|
-- | Flip a Do to an Undo, and an Undo to a Do.
|
|
invertUndoable :: Undoable a -> Undoable a
|
|
invertUndoable undoable = case undoable of
|
|
Do a -> Undo a
|
|
Undo a -> Do a
|
|
|
|
-- | Records actions so that they can be undone.
|
|
data HistoryEvent
|
|
= MovedNode -- TODO Record which node, and where the node was moved
|
|
-- from (and to).
|
|
| AddedNode ElemId (Double, Double) -- Id of node and position
|
|
deriving (Show, Eq)
|
|
|
|
emptyAppState :: AppState
|
|
emptyAppState =
|
|
AppState
|
|
{ _asMovingNode = Nothing,
|
|
_asEdges = [],
|
|
_asCurrentEdge = Nothing,
|
|
_asElements = mempty,
|
|
_asFPSr = 0,
|
|
_asHistory = [],
|
|
_asUndoPosition = [],
|
|
_asBiggestID = 0,
|
|
_asTransform = Transform 1 (0, 0)
|
|
}
|
|
|
|
emptyInputs :: Inputs
|
|
emptyInputs =
|
|
Inputs
|
|
{ _inMouseXandY = (0, 0),
|
|
_inTime = MkSystemTime 0 0,
|
|
_inPrevTime = MkSystemTime 0 0,
|
|
_inEvents = mempty,
|
|
_inTranslation = Nothing
|
|
}
|
|
|
|
-- | Add a new HistoryEvent and reset _asUndoPosition.
|
|
addHistoryEvent :: HistoryEvent -> AppState -> AppState
|
|
addHistoryEvent event state@AppState {_asHistory, _asUndoPosition} =
|
|
let updatedHistory = Do event : _asHistory
|
|
in state
|
|
{ _asHistory = updatedHistory,
|
|
_asUndoPosition = updatedHistory
|
|
}
|
|
|
|
-- | Add an event to the event queue in Inputs.
|
|
addEvent :: InputEvent -> Inputs -> Inputs
|
|
addEvent event inputs@Inputs {_inEvents} = inputs {_inEvents = event : _inEvents}
|
|
|
|
-- | Uses the argument function to combine the tuples.
|
|
elementwiseOp :: (a -> b -> c) -> (a, a) -> (b, b) -> (c, c)
|
|
elementwiseOp f (x0, x1) (y0, y1) =
|
|
(f x0 y0, f x1 y1)
|
|
|
|
renderCairo :: Coercible a GI.Cairo.Context => a -> Render c -> IO c
|
|
renderCairo c r = withManagedPtr c $ \pointer ->
|
|
runReaderT (runRender r) (Cairo (castPtr pointer))
|
|
|
|
drawLine :: Transform -> (Double, Double) -> (Double, Double) -> Render ()
|
|
drawLine Transform {_tScale} (fromX, fromY) (toX, toY) = do
|
|
Cairo.setSourceRGB 0 1 0
|
|
Cairo.setLineWidth (5 * _tScale)
|
|
|
|
Cairo.moveTo fromX fromY
|
|
Cairo.lineTo toX toY
|
|
Cairo.stroke
|
|
|
|
_drawCircle :: (Double, Double) -> Render ()
|
|
_drawCircle (x, y) = do
|
|
-- setSourceRGB 1 0 0
|
|
Cairo.setLineWidth 1
|
|
-- moveTo x y
|
|
let radius = 20
|
|
let tau = 2 * pi
|
|
Cairo.arc x y radius 0 tau
|
|
Cairo.stroke
|
|
|
|
drawNode :: Transform -> (Int, Element) -> Render ()
|
|
drawNode t (elemId, element) = _ntDraw (_elType element) t (elemId, element)
|
|
|
|
-- TODO This name should indicate that it's adding in the location of
|
|
-- the element.
|
|
portLocation :: Int -> Element -> (Double, Double)
|
|
portLocation port element =
|
|
elementwiseOp
|
|
(+)
|
|
(_elPosition element)
|
|
(_ntPortLocations (_elType element) port)
|
|
|
|
drawCurrentEdge :: (Double, Double) -> AppState -> Render ()
|
|
drawCurrentEdge mousePosition AppState {_asCurrentEdge, _asElements, _asTransform} =
|
|
case _asCurrentEdge of
|
|
Nothing -> pure ()
|
|
Just port -> case IntMap.lookup (_unElemId $ _pNode port) _asElements of
|
|
Nothing -> pure ()
|
|
Just element ->
|
|
drawLine
|
|
_asTransform
|
|
(transform _asTransform (portLocation (_pPort port) element))
|
|
mousePosition
|
|
|
|
drawEdges :: AppState -> Render ()
|
|
drawEdges AppState {_asEdges, _asElements, _asTransform} =
|
|
traverse_ drawEdge _asEdges
|
|
where
|
|
drawEdge :: (Port, Port) -> Render ()
|
|
drawEdge (from, to) = case (lookupFrom, lookupTo) of
|
|
(Just fromElem, Just toElem) ->
|
|
drawLine
|
|
_asTransform
|
|
(transform _asTransform (portLocation (_pPort from) fromElem))
|
|
(transform _asTransform (portLocation (_pPort to) toElem))
|
|
_ -> pure ()
|
|
where
|
|
lookupFrom = IntMap.lookup (_unElemId $ _pNode from) _asElements
|
|
lookupTo = IntMap.lookup (_unElemId $ _pNode to) _asElements
|
|
|
|
updateBackground :: p -> IORef Inputs -> IORef AppState -> Render ()
|
|
updateBackground _canvas inputsRef stateRef = do
|
|
-- width <- (realToFrac <$> (liftIO $ Gtk.widgetGetAllocatedWidth canvas)
|
|
-- :: Render Double)
|
|
-- height <- (realToFrac <$> (liftIO $ Gtk.widgetGetAllocatedHeight canvas)
|
|
-- :: Render Double)
|
|
|
|
-- TODO This should be moved into the setup phase
|
|
Cairo.setSourceRGB 0 0 0
|
|
Cairo.paint
|
|
|
|
state <- Cairo.liftIO $ readIORef stateRef
|
|
inputs <- Cairo.liftIO $ readIORef inputsRef
|
|
Cairo.setSourceRGB 1 1 1
|
|
Cairo.moveTo 10 10
|
|
Cairo.showText ("fps=" <> show (_asFPSr state))
|
|
drawCurrentEdge (_inMouseXandY inputs) state
|
|
drawEdges state
|
|
traverse_
|
|
(drawNode (_asTransform state))
|
|
(IntMap.toList (_asElements state))
|
|
|
|
findElementByPosition ::
|
|
IntMap.IntMap Element -> (Double, Double) -> Maybe (Int, Element)
|
|
findElementByPosition elements (mouseX, mouseY) =
|
|
let mouseInElement (_elementId, Element {_elPosition, _elType, _elNumPorts}) =
|
|
let (x, y) = _elPosition
|
|
(width, height) = _ntSize _elType _elNumPorts
|
|
in mouseX >= x && mouseX <= (x + width)
|
|
&& mouseY >= y
|
|
&& mouseY <= (y + height)
|
|
in find mouseInElement (IntMap.toList elements)
|
|
|
|
getFps :: Inputs -> Double
|
|
getFps inputs =
|
|
let (MkSystemTime seconds nanoseconds) = _inTime inputs
|
|
(MkSystemTime oldSeconds oldNanoseconds) = _inPrevTime inputs
|
|
secondsDiff = seconds - oldSeconds
|
|
nanosecondDiff = nanoseconds - oldNanoseconds
|
|
fps =
|
|
if secondsDiff == 0
|
|
then fromIntegral (div (10 ^ (9 :: Int)) nanosecondDiff)
|
|
else 1 / fromIntegral secondsDiff
|
|
in if fps >= 200
|
|
then fromIntegral $ div (truncate fps) 100 * (100 :: Int)
|
|
else fps
|
|
|
|
clickOnNode ::
|
|
ElemId ->
|
|
(Double, Double) -> -- Click position where (0,0) is top left of element
|
|
AppState ->
|
|
AppState
|
|
clickOnNode elemId relativePosition oldState@AppState {_asMovingNode, _asHistory, _asElements, _asCurrentEdge, _asEdges} =
|
|
let portClicked = case IntMap.lookup (_unElemId elemId) _asElements of
|
|
Nothing -> Nothing
|
|
Just element ->
|
|
_ntPortClicked (_elType element) relativePosition element
|
|
in case _asMovingNode of
|
|
Nothing -> case portClicked of
|
|
Nothing -> oldState {_asMovingNode = Just elemId}
|
|
Just port -> case _asCurrentEdge of
|
|
Nothing -> oldState {_asCurrentEdge = Just $ Port {_pNode = elemId, _pPort = port}}
|
|
Just edgePort ->
|
|
oldState
|
|
{ _asEdges =
|
|
( edgePort,
|
|
Port {_pNode = elemId, _pPort = port}
|
|
) :
|
|
_asEdges,
|
|
_asCurrentEdge = Nothing
|
|
}
|
|
Just _ ->
|
|
addHistoryEvent MovedNode $
|
|
oldState {_asMovingNode = Nothing}
|
|
|
|
-- | Add a node to the canvas at the given position in Element
|
|
-- coordinates with a known ID.
|
|
addNodeWithId :: ElemId -> (Double, Double) -> AppState -> AppState
|
|
addNodeWithId
|
|
nodeId
|
|
addPosition
|
|
state@AppState {_asElements, _asHistory, _asBiggestID} =
|
|
let applyNode =
|
|
Element
|
|
{ _elPosition = addPosition,
|
|
_elZ = 0,
|
|
_elType = apply,
|
|
_elNumPorts = _ntNumInitialPorts apply
|
|
}
|
|
newElements =
|
|
IntMap.insert (_unElemId nodeId) applyNode _asElements
|
|
in addHistoryEvent (AddedNode nodeId addPosition) $
|
|
state
|
|
{ _asElements = newElements,
|
|
_asBiggestID = max _asBiggestID nodeId
|
|
}
|
|
|
|
-- | Add a node to the canvas at the given position.
|
|
addNode :: (Double, Double) -> AppState -> AppState
|
|
addNode addPosition state@AppState {_asBiggestID} =
|
|
addNodeWithId (1 + _asBiggestID) addPosition state
|
|
|
|
removeNode :: ElemId -> AppState -> AppState
|
|
removeNode nodeId oldState@AppState {_asElements} =
|
|
oldState {_asElements = IntMap.delete (_unElemId nodeId) _asElements}
|
|
|
|
undo :: AppState -> AppState
|
|
undo oldState@AppState {_asHistory, _asUndoPosition} = newState
|
|
where
|
|
newState = case _asUndoPosition of
|
|
[] -> oldState
|
|
historyEvent : restOfHistory ->
|
|
undidState
|
|
{ _asHistory = invertUndoable historyEvent : _asHistory,
|
|
_asUndoPosition = restOfHistory
|
|
}
|
|
where
|
|
undidState = case historyEvent of
|
|
Do MovedNode -> oldState -- TODO Implement undo move node.
|
|
Do (AddedNode nodeId _) -> removeNode nodeId oldState
|
|
Undo (AddedNode nodeId position) ->
|
|
addNodeWithId nodeId position oldState
|
|
Undo MovedNode -> oldState -- TODO Implement undo Undo move.
|
|
|
|
-- | Abort the current action. This includes resetting the _asUndoPosition.
|
|
abort :: AppState -> AppState
|
|
abort state@AppState {_asHistory, _asUndoPosition} =
|
|
state {_asUndoPosition = _asHistory}
|
|
|
|
-- | Adjust the scale factor.
|
|
adjustScale :: (Double, Double) -> Double -> AppState -> AppState
|
|
adjustScale mousePosition scaleAdjustment state@AppState {_asTransform} =
|
|
state
|
|
{ _asTransform =
|
|
_asTransform
|
|
{ _tScale = newScale,
|
|
_tTranslate = newTranslate
|
|
}
|
|
}
|
|
where
|
|
oldScale = _tScale _asTransform
|
|
adjustedScale = oldScale * scaleAdjustment
|
|
newScale =
|
|
if adjustedScale > minimumScale
|
|
then adjustedScale
|
|
else oldScale
|
|
-- When zooming, elements that are at the mouse position should
|
|
-- stay at the mouse position under the new transform. Elements at
|
|
-- the mouse position are at
|
|
-- unTransform _asTransform mousePosition
|
|
-- So
|
|
-- mousePosition =
|
|
-- transform newTransform (unTransform _asTransform mousePosision)
|
|
-- Which when solved for the new translation produces the code below.
|
|
unTransformedMousePosition = unTransform _asTransform mousePosition
|
|
newTranslate =
|
|
elementwiseOp
|
|
(-)
|
|
mousePosition
|
|
( Tuple.both
|
|
(* newScale)
|
|
unTransformedMousePosition
|
|
)
|
|
|
|
processInput :: Inputs -> InputEvent -> AppState -> AppState
|
|
processInput Inputs {_inMouseXandY} inputEvent oldState =
|
|
case inputEvent of
|
|
ClickOnNode elemId relativePosition -> clickOnNode elemId relativePosition oldState
|
|
AddNode addPosition -> addNode addPosition oldState
|
|
UndoEvent -> undo oldState
|
|
AbortEvent -> abort oldState
|
|
ScaleAdjustEvent scaleAdjustment -> adjustScale _inMouseXandY scaleAdjustment oldState
|
|
|
|
processInputs :: Inputs -> AppState -> AppState
|
|
processInputs
|
|
inputs@Inputs {_inEvents}
|
|
oldState@AppState {_asElements, _asMovingNode} =
|
|
let compose = foldr (.) id
|
|
in compose (fmap (processInput inputs) _inEvents) oldState
|
|
|
|
-- | Update the state based on the inputs and the old state.
|
|
updateState :: Inputs -> AppState -> AppState
|
|
updateState
|
|
inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation}
|
|
oldState@AppState {_asElements, _asMovingNode, _asTransform} =
|
|
let -- Move the asMovingNode to MouseXandY
|
|
newElements = case _asMovingNode of
|
|
Nothing -> _asElements
|
|
Just nodeId ->
|
|
IntMap.adjust
|
|
( \oldNode@Element {_elPosition, _elType} ->
|
|
let newPosition =
|
|
elementwiseOp
|
|
(-)
|
|
(unTransform _asTransform _inMouseXandY)
|
|
(_ntHandleLocation _elType)
|
|
in oldNode {_elPosition = newPosition}
|
|
)
|
|
(_unElemId nodeId)
|
|
_asElements
|
|
newTransform =
|
|
case _inTranslation of
|
|
Nothing -> _asTransform
|
|
Just (Panning initialMousePosition initialTranslation) ->
|
|
_asTransform
|
|
{ _tTranslate =
|
|
elementwiseOp
|
|
(+)
|
|
initialTranslation
|
|
(elementwiseOp (-) _inMouseXandY initialMousePosition)
|
|
}
|
|
in oldState
|
|
{ _asElements = newElements,
|
|
_asFPSr = getFps inputs,
|
|
_asTransform = newTransform
|
|
}
|
|
|
|
---------- Input Callbacks ---------------------------------
|
|
leftClickAction ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
(Double, Double) ->
|
|
IO ()
|
|
leftClickAction inputsRef stateRef mousePosition =
|
|
do
|
|
state <- readIORef stateRef
|
|
let mElem = findElementByPosition (_asElements state) mousePosition
|
|
|
|
addClickEvent inputs@Inputs {_inEvents} =
|
|
case mElem of
|
|
Nothing -> inputs
|
|
Just (elemId, element) ->
|
|
addEvent
|
|
( ClickOnNode
|
|
(ElemId elemId)
|
|
(elementwiseOp (-) mousePosition (_elPosition element))
|
|
)
|
|
inputs
|
|
modifyIORef'
|
|
inputsRef
|
|
addClickEvent
|
|
|
|
rightClickAction ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
(Double, Double) ->
|
|
IO ()
|
|
rightClickAction inputsRef _stateRef mousePosition =
|
|
do
|
|
modifyIORef'
|
|
inputsRef
|
|
(addEvent (AddNode mousePosition))
|
|
pure ()
|
|
|
|
backgroundPress ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
MouseButton ->
|
|
(Double, Double) ->
|
|
IO ()
|
|
backgroundPress inputsRef stateRef mouseButton rawMousePosition = do
|
|
putStrLn ("Background pressed by " <> show mouseButton)
|
|
state <- readIORef stateRef
|
|
let mousePosition = windowToElementCoordinates state rawMousePosition
|
|
case mouseButton of
|
|
RightMouseButton -> rightClickAction inputsRef stateRef mousePosition
|
|
LeftMouseButton ->
|
|
leftClickAction inputsRef stateRef mousePosition
|
|
_ -> mempty
|
|
|
|
addUndoInputAction :: IORef Inputs -> IO ()
|
|
addUndoInputAction inputsRef = do
|
|
putStrLn "Undo"
|
|
modifyIORef' inputsRef (addEvent UndoEvent)
|
|
pure ()
|
|
|
|
addAbortAction :: IORef Inputs -> IO ()
|
|
addAbortAction inputsRef = do
|
|
putStrLn "Abort"
|
|
modifyIORef' inputsRef (addEvent AbortEvent)
|
|
pure ()
|
|
|
|
keyPress :: IORef Inputs -> IORef AppState -> KeyEvent -> IO ()
|
|
keyPress inputsRef stateRef keyEvent = do
|
|
state <- readIORef stateRef
|
|
inputs <- readIORef inputsRef
|
|
case keyEvent of
|
|
UndoKey -> addUndoInputAction inputsRef
|
|
AbortKey -> addAbortAction inputsRef
|
|
TranslateKey ->
|
|
if
|
|
| isNothing (_inTranslation inputs) ->
|
|
writeIORef
|
|
inputsRef
|
|
( inputs
|
|
{ _inTranslation =
|
|
Just
|
|
( Panning
|
|
(_inMouseXandY inputs)
|
|
(_tTranslate (_asTransform state))
|
|
)
|
|
}
|
|
)
|
|
>> putStrLn "translate key pressed"
|
|
| otherwise -> pure ()
|
|
UnknownKey _ -> pure ()
|
|
pure ()
|
|
|
|
keyRelease :: IORef Inputs -> KeyEvent -> IO ()
|
|
keyRelease inputsRef keyEvent = do
|
|
case keyEvent of
|
|
TranslateKey ->
|
|
modifyIORef'
|
|
inputsRef
|
|
(\inputs -> inputs {_inTranslation = Nothing})
|
|
>> putStrLn "translate key released"
|
|
_ -> pure ()
|
|
|
|
addScaleAdjustAction ::
|
|
-- | Amount by which to change the scale factor
|
|
Double ->
|
|
IORef Inputs ->
|
|
IO ()
|
|
addScaleAdjustAction scaleDelta inputsRef = do
|
|
putStrLn ("Adjusting scale by " <> show scaleDelta)
|
|
modifyIORef' inputsRef (addEvent (ScaleAdjustEvent scaleDelta))
|
|
pure ()
|
|
|
|
scroll :: IORef Inputs -> Double -> IO ()
|
|
scroll inputsRef deltaY = do
|
|
-- scale in (zooming in) is negative (usually -1), scale out
|
|
-- (zooming out) is positive (usually 1)
|
|
if deltaY /= 0.0
|
|
then addScaleAdjustAction (1 - (0.2 * deltaY)) inputsRef
|
|
else pure ()
|
|
|
|
-- | Called by GtkGui.timeoutCallback
|
|
step ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
SystemTime ->
|
|
(Double, Double) ->
|
|
IO a ->
|
|
IO a
|
|
step inputsRef stateRef newTime (mouseX, mouseY) drawCommand = do
|
|
modifyIORef'
|
|
inputsRef
|
|
( \inputs@Inputs {_inTime} ->
|
|
inputs
|
|
{ _inMouseXandY = (mouseX, mouseY),
|
|
_inTime = newTime,
|
|
_inPrevTime = _inTime
|
|
}
|
|
)
|
|
inputs <- readIORef inputsRef
|
|
modifyIORef' stateRef (updateState inputs . processInputs inputs)
|
|
modifyIORef' inputsRef (\i -> i {_inEvents = []}) -- Clear the event queue.
|
|
drawCommand
|