content: -- This file is formatted with Ormolu
  {-# LANGUAGE BlockArguments #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE GADTs #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiWayIf #-}
  {-# LANGUAGE NamedFieldPuns #-}
  {-# LANGUAGE NumericUnderscores #-}
  {-# 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 (..),
      KeyInput (..),
      KeyEvent (..),
      renderCairo,
      updateBackground,
      backgroundPress,
      keyPress,
      keyRelease,
      scroll,
      step,
    )
  where
  
  -- import Debug.Trace (trace)
  
  import Control.Monad (when)
  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 Data.Maybe (fromMaybe, isNothing)
  import qualified Data.Set as Set
  import qualified Data.Text as 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
  
  panSpeed :: Double
  panSpeed = 2000
  
  baseFontSize :: Double
  baseFontSize = 24
  
  -- Types
  
  -- | An Enum of mouse buttons, so order is important!
  data MouseButton
    = LeftMouseButton
    | MiddleMouseButton
    | RightMouseButton
    | UnknownMouseButton
    deriving (Eq, Ord, Enum, Bounded, Show)
  
  data KeyInput = KeyInput
    { _kiKeyString :: Text.Text,
      _kiKeyEvent :: KeyEvent
    }
    deriving (Show, Eq)
  
  -- | What action should be taken when you press a key?
  data KeyEvent
    = UndoKey
    | AbortKey
    | MouseTranslateKey
    | MoveUp
    | MoveLeft
    | MoveDown
    | MoveRight
    | OtherKey Text.Text
    deriving (Eq, Ord, Show)
  
  -- | 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) ->
           Maybe Port -> -- Currently selected port
           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)
    }
    deriving (Show, Eq)
  
  -- 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,
      _elPortText :: !(IntMap.IntMap Text.Text)
    }
  
  -- | 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
    }
    deriving (Eq, Ord, Show)
  
  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),
      -- | All keys currently being pressed.
      _inPressedKeys :: !(Set.Set KeyEvent)
    }
  
  -- 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. Each edge is a set of at least
      -- two ports that are connected.
      _asEdges ::
        !( Set.Set
             (Set.Set Port) -- Each Set of Ports is a single "edge".
         ),
      -- | Iff Just, an edge is currently being draw where the ElemId is
      -- one end of the edge.
      _asCurrentEdge :: !(Maybe Port),
      -- TODO current edge and current port have the same type. Can they
      -- be combined? Also, may want to edit the node type /
      -- handle. Should that be a "port" too?
  
      -- | Iff Just, then currently the text of this port is being edited.
      _asCurrentPort :: !(Maybe Port),
      _asElements :: !(IntMap.IntMap Element),
      -- | FPS rounded down to nearest hundred if over 200 fps.
      _asFPSr :: !Int,
      -- | 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
        !MouseButton
        !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 ----------
  
  ---- Apply Node ----
  
  handleWidth :: Double
  handleWidth = 70
  
  portWidth :: Double
  portWidth = 100
  
  applyNodeHeight :: Double
  applyNodeHeight = 40
  
  -- | Draw an apply node. This function's type will probably change
  -- since some of this could be done in drawNode.
  drawApply :: Transform -> (Int, Element) -> Maybe Port -> Render ()
  drawApply transformation (elemId, Element {..}) selectedPort = 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
        fontHeight = baseFontSize * scale
        drawPort portNum = do
          if
              | selectedPort
                  == Just (Port {_pNode = ElemId elemId, _pPort = portNum}) ->
                Cairo.setSourceRGB 0 1 0
              | portNum == 0 -> Cairo.setSourceRGB 1 1 1
              | otherwise -> Cairo.setSourceRGB 1 0 0
          let portText = fromMaybe "" $ IntMap.lookup portNum _elPortText
          Cairo.rectangle
            (x + scaledHandleWidth + scaledPortWidth * fromIntegral portNum)
            y
            scaledPortWidth
            scaledHeight
          Cairo.moveTo xPos (y - 0.4 * fontHeight)
          Cairo.showText portText
          Cairo.stroke
          where
            xPos = x + scaledHandleWidth + scaledPortWidth * fromIntegral portNum
  
    Cairo.setSourceRGB 0.5 0.5 0.5
    Cairo.setLineWidth (3 * scale)
    -- Draw the handle
    Cairo.rectangle x y scaledHandleWidth scaledHeight
    Cairo.moveTo (x + 5 * scale) (y + scale * 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 = 3,
        _ntPortClicked = applyPortClicked,
        _ntDraw = drawApply,
        _ntPortLocations = applyPortLocations,
        _ntHandleLocation = (handleWidth / 2, applyNodeHeight / 2),
        _ntSize = applySize
      }
  
  ---- TextNode ----
  
  -------- Types ----------
  
  -- | 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 = mempty,
        _asCurrentEdge = Nothing,
        _asCurrentPort = 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,
        _inPressedKeys = mempty
      }
  
  -- | 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 :: AppState -> (Int, Element) -> Render ()
  drawNode AppState {_asCurrentPort, _asTransform} (elemId, element) =
    _ntDraw (_elType element) _asTransform (elemId, element) _asCurrentPort
  
  -- 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
      (Set.toList _asEdges >>= allPairs)
    where
      -- TODO Replace with a minimum spanning tree.
      -- For each edge, generate all pairs of ports
      allPairs :: Set.Set Port -> [(Port, Port)]
      allPairs portSet = do
        let ports = Set.toList portSet
        a <- ports
        let portsMinusA = Set.toList (Set.delete a portSet)
        b <- portsMinusA
        [(a, b)]
  
      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
    Cairo.setFontSize baseFontSize
  
    state <- Cairo.liftIO $ readIORef stateRef
    inputs <- Cairo.liftIO $ readIORef inputsRef
    let fps = _asFPSr state
    if fps >= 120
      then Cairo.setSourceRGB 1 1 1
      else Cairo.setSourceRGB 1 0 0
    Cairo.moveTo 10 baseFontSize
    Cairo.showText ("fps=" <> show fps)
    Cairo.setFontSize (baseFontSize * _tScale (_asTransform state))
    drawCurrentEdge (_inMouseXandY inputs) state
    drawEdges state
    traverse_
      (drawNode 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)
  
  -- | Time between steps in seconds.
  calcFrameTime :: Inputs -> Double
  calcFrameTime Inputs {_inTime, _inPrevTime} =
    frameTime
    where
      nanoToSecond nanoSecond = fromIntegral nanoSecond / (10 ^ (9 :: Int))
      frameTime =
        fromIntegral secondsDiff + nanosecondDiff
      (MkSystemTime seconds nanoseconds) = _inTime
      (MkSystemTime oldSeconds oldNanoseconds) = _inPrevTime
      secondsDiff = seconds - oldSeconds
      -- nanoseconds in MkSystemTime are unsigned, so they can not be
      -- directly subtracted.
      nanosecondDiff = nanoToSecond nanoseconds - nanoToSecond oldNanoseconds
  
  getFps :: Inputs -> Int
  getFps inputs =
    let fps :: Int
        fps = round $ 1 / calcFrameTime inputs
     in if fps >= 200
          then div fps 100 * (100 :: Int)
          else fps
  
  clickOnNode ::
    MouseButton ->
    ElemId ->
    (Double, Double) -> -- Click position where (0,0) is top left of element
    AppState ->
    AppState
  clickOnNode mouseButton = case mouseButton of
    LeftMouseButton -> clickOnNodePrimaryAction
    RightMouseButton -> clickOnNodeSecondaryAction
    _ -> \_ _ -> id
  
  clickOnNodePrimaryAction ::
    ElemId ->
    (Double, Double) -> -- Click position where (0,0) is top left of element
    AppState ->
    AppState
  clickOnNodePrimaryAction
    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 =
                        -- TODO May want to add one of the ports to the
                        -- other's existing edge.
                        Set.insert
                          ( Set.fromList
                              [ edgePort,
                                Port {_pNode = elemId, _pPort = port}
                              ]
                          )
                          _asEdges,
                      _asCurrentEdge = Nothing
                    }
            Just _ ->
              addHistoryEvent MovedNode $
                oldState {_asMovingNode = Nothing}
  
  clickOnNodeSecondaryAction ::
    ElemId ->
    (Double, Double) -> -- Click position where (0,0) is top left of element
    AppState ->
    AppState
  clickOnNodeSecondaryAction
    elemId
    relativePosition
    oldState@AppState
      { _asMovingNode,
        _asHistory,
        _asElements,
        _asCurrentPort,
        _asEdges
      } =
      let portClicked = case IntMap.lookup (_unElemId elemId) _asElements of
            Nothing -> Nothing
            Just element ->
              _ntPortClicked (_elType element) relativePosition element
       in case (portClicked, _asCurrentPort) of
            (Just port, _) ->
              oldState
                { _asCurrentPort =
                    Just $
                      Port
                        { _pNode = elemId,
                          _pPort = port
                        }
                }
            _ -> oldState {_asCurrentPort = 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,
                _elPortText = mempty
              }
          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 mouseButton elemId relativePosition ->
        clickOnNode mouseButton 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
  
  -- The amount by which to adjust the translation when the panning keys
  -- are pressed.
  keyPanAdjustment :: Double -> Set.Set KeyEvent -> (Double, Double)
  keyPanAdjustment frameTime pressedKeys = (xAdjust, yAdjust)
    where
      moveAmount = frameTime * panSpeed
      moveLeft = if Set.member MoveLeft pressedKeys then moveAmount else 0
      moveRight = if Set.member MoveRight pressedKeys then (- moveAmount) else 0
      moveUp = if Set.member MoveUp pressedKeys then moveAmount else 0
      moveDown = if Set.member MoveDown pressedKeys then (- moveAmount) else 0
      xAdjust = moveLeft + moveRight
      yAdjust = moveUp + moveDown
  
  -- | Update the state based on the inputs and the old state.
  updateState :: Inputs -> AppState -> AppState
  updateState
    inputs@Inputs {_inMouseXandY, _inEvents, _inTranslation, _inPressedKeys}
    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
          mousePanTranslate =
            case _inTranslation of
              Nothing -> _tTranslate _asTransform
              Just (Panning initialMousePosition initialTranslation) ->
                elementwiseOp
                  (+)
                  initialTranslation
                  (elementwiseOp (-) _inMouseXandY initialMousePosition)
  
          newTranslate =
            elementwiseOp
              (+)
              mousePanTranslate
              ( keyPanAdjustment
                  (calcFrameTime inputs)
                  _inPressedKeys
              )
       in oldState
            { _asElements = newElements,
              _asFPSr = getFps inputs,
              _asTransform = _asTransform {_tTranslate = newTranslate}
            }
  
  ---------- Input Callbacks ---------------------------------
  leftClickAction ::
    IORef Inputs ->
    IORef AppState ->
    (Double, Double) ->
    IO ()
  leftClickAction inputsRef stateRef mousePosition =
    do
      state <- readIORef stateRef
      -- print (_asEdges state)
      let mElem = findElementByPosition (_asElements state) mousePosition
  
          addClickEvent inputs@Inputs {_inEvents} =
            case mElem of
              Nothing -> inputs
              Just (elemId, element) ->
                addEvent
                  ( ClickOnNode
                      LeftMouseButton
                      (ElemId elemId)
                      (elementwiseOp (-) mousePosition (_elPosition element))
                  )
                  inputs
      writeIORef stateRef (state {_asCurrentPort = Nothing})
      modifyIORef'
        inputsRef
        addClickEvent
  
  -- TODO Refactor with leftClickAction. Passing the MouseButton to
  -- ClickOnNode feels wrong since actions should be separate from
  -- inputs. Perhaps PrimaryAction and SecondaryAction instead?
  rightClickAction ::
    IORef Inputs ->
    IORef AppState ->
    (Double, Double) ->
    IO ()
  rightClickAction inputsRef stateRef mousePosition =
    do
      state <- readIORef stateRef
      let mElem = findElementByPosition (_asElements state) mousePosition
          addClickEvent inputs@Inputs {_inEvents} =
            case mElem of
              Nothing ->
                addEvent (AddNode mousePosition) inputs
              Just (elemId, element) ->
                addEvent
                  ( ClickOnNode -- TODO Event should be move node or
                  -- something like that. Selecting a port should be
                  -- instant, not an event.
                      RightMouseButton
                      (ElemId elemId)
                      (elementwiseOp (-) mousePosition (_elPosition element))
                  )
                  inputs
      when
        (isNothing mElem)
        (writeIORef stateRef (state {_asCurrentPort = Nothing}))
  
      modifyIORef'
        inputsRef
        addClickEvent
      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 ()
  
  editPortText :: Port -> Text.Text -> AppState -> AppState
  editPortText Port {_pNode, _pPort} newText oldState@AppState {_asElements} =
    oldState
      { _asElements =
          IntMap.adjust modifyElem (_unElemId _pNode) _asElements
      }
    where
      modifyElem :: Element -> Element
      modifyElem el@Element {_elPortText} =
        el {_elPortText = IntMap.alter changeText _pPort _elPortText}
  
      changeText :: (Maybe Text.Text -> Maybe Text.Text)
      changeText = case newText of
        -- "\b" is backspace
        "\b" ->
          \mText -> do
            -- Maybe monad
            text <- mText
            (inits, _) <- Text.unsnoc text
            pure inits
        _ -> Just . maybe newText (<> newText)
  
  keyPress :: IORef Inputs -> IORef AppState -> KeyInput -> IO ()
  keyPress inputsRef stateRef keyInput = do
    -- print keyInput
    let keyEvent = _kiKeyEvent keyInput
    state <- readIORef stateRef
    preKeyPressedInputs <- readIORef inputsRef
    case _asCurrentPort state of
      Just port ->
        modifyIORef' stateRef (editPortText port (_kiKeyString keyInput))
      Nothing -> do
        let inputs =
              preKeyPressedInputs
                { _inPressedKeys =
                    Set.insert keyEvent (_inPressedKeys preKeyPressedInputs)
                }
        writeIORef inputsRef inputs
        -- print (_inPressedKeys inputs)
        case keyEvent of
          UndoKey -> addUndoInputAction inputsRef
          AbortKey -> addAbortAction inputsRef
          MouseTranslateKey ->
            if
                | isNothing (_inTranslation inputs) ->
                  writeIORef
                    inputsRef
                    ( inputs
                        { _inTranslation =
                            Just
                              ( Panning
                                  (_inMouseXandY inputs)
                                  (_tTranslate (_asTransform state))
                              )
                        }
                    )
                    >> putStrLn "translate key pressed"
                | otherwise -> pure ()
          OtherKey keyStr -> print keyStr
          _ -> pure ()
  
  -- pure
  -- ()
  
  keyRelease :: IORef Inputs -> KeyInput -> IO ()
  keyRelease inputsRef keyInput = do
    let keyEvent = _kiKeyEvent keyInput
    modifyIORef'
      inputsRef
      ( \inputs ->
          inputs
            { _inPressedKeys = Set.delete keyEvent (_inPressedKeys inputs)
            }
      )
    case keyEvent of
      MouseTranslateKey ->
        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 =
    -- 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.
    -- state <- readIORef stateRef
    -- print (_asCurrentPort state)
    drawCommand
  