mirror of
https://github.com/rgleichman/glance.git
synced 2024-09-11 15:05:41 +03:00
390 lines
11 KiB
Haskell
390 lines
11 KiB
Haskell
-- This file is formatted with Ormolu
|
|
{-# LANGUAGE BlockArguments #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE GADTs #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedLabels #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Main (main) where
|
|
|
|
import Control.Monad
|
|
import Control.Monad.IO.Class (MonadIO)
|
|
import Control.Monad.Trans.Reader (runReaderT)
|
|
import Data.Coerce
|
|
import Data.Foldable (traverse_)
|
|
import Data.GI.Base
|
|
import Data.IORef
|
|
import qualified Data.IntMap.Strict as IntMap
|
|
import Data.List
|
|
import Data.Maybe (fromJust)
|
|
import Data.Time.Clock.System
|
|
import Foreign.Ptr (castPtr)
|
|
import GHC.Word (Word32)
|
|
import qualified GI.Cairo
|
|
import qualified GI.GLib as GLib
|
|
import qualified GI.Gdk as Gdk
|
|
-- import qualified GI.GdkPixbuf as GP
|
|
import qualified GI.Gio as Gio
|
|
import qualified GI.Gtk as Gtk
|
|
import Graphics.Rendering.Cairo
|
|
import Graphics.Rendering.Cairo.Internal (Render (runRender))
|
|
import Graphics.Rendering.Cairo.Types (Cairo (Cairo))
|
|
|
|
leftMouseButton :: Word32
|
|
leftMouseButton = 1
|
|
|
|
rightMouseButton :: Word32
|
|
rightMouseButton = 3
|
|
|
|
nodeSize :: (Double, Double)
|
|
nodeSize = (100, 40)
|
|
|
|
-- TODO USE newtype for element ID.
|
|
newtype ElemId = ElemId {_unElemId :: Int} deriving (Show, Eq, Ord)
|
|
|
|
-- | A graphical element that can be clicked
|
|
data Element = Element
|
|
{ -- | (x, y) of top left corner
|
|
_elPosition :: !(Double, Double),
|
|
-- | (width, height)
|
|
_elSize :: !(Double, Double),
|
|
-- | Depth. Higher values are drawn on top
|
|
-- _elZ is currently ignored
|
|
_elZ :: Int
|
|
}
|
|
|
|
data Inputs = Inputs
|
|
{ _inMouseXandY :: !(Double, Double),
|
|
_inTime :: SystemTime,
|
|
_inPrevTime :: SystemTime,
|
|
_inEvents :: [InputEvent]
|
|
}
|
|
|
|
data AppState = AppState
|
|
{ -- | _asElements key
|
|
_asMovingNode :: Maybe ElemId,
|
|
_asEdges :: [(Element, Element)],
|
|
_asElements :: IntMap.IntMap Element,
|
|
-- | FPS rouned down to nearest hundred if over 200 fps.
|
|
_asFPSr :: Double
|
|
}
|
|
|
|
data InputEvent
|
|
= -- Which node was clicked and the relative click position within a node.
|
|
ClickOnNode
|
|
ElemId
|
|
(Double, Double) -- relative mouse position
|
|
Word32 -- mouse button
|
|
|
|
emptyAppState :: AppState
|
|
emptyAppState =
|
|
AppState
|
|
{ _asMovingNode = Nothing,
|
|
_asEdges = [],
|
|
_asElements = mempty,
|
|
_asFPSr = 0
|
|
}
|
|
|
|
emptyInputs :: Inputs
|
|
emptyInputs =
|
|
Inputs
|
|
{ _inMouseXandY = (0, 0),
|
|
_inTime = MkSystemTime 0 0,
|
|
_inPrevTime = MkSystemTime 0 0,
|
|
_inEvents = mempty
|
|
}
|
|
|
|
renderCairo :: Coercible a (ManagedPtr ()) => a -> Render c -> IO c
|
|
renderCairo c r = withManagedPtr c $ \pointer ->
|
|
runReaderT (runRender r) (Cairo (castPtr pointer))
|
|
|
|
getXandY ::
|
|
MonadIO f =>
|
|
Gdk.EventButton ->
|
|
f (Double, Double)
|
|
getXandY event =
|
|
(\x y -> (x, y)) <$> Gdk.getEventButtonX event <*> Gdk.getEventButtonY event
|
|
|
|
_drawLine :: (Double, Double) -> (Double, Double) -> Render ()
|
|
_drawLine (fromX, fromY) (toX, toY) = do
|
|
setSourceRGB 0 1 0
|
|
setLineWidth 5
|
|
|
|
moveTo fromX fromY
|
|
lineTo toX toY
|
|
stroke
|
|
|
|
_drawCircle :: (Double, Double) -> Render ()
|
|
_drawCircle (x, y) = do
|
|
-- setSourceRGB 1 0 0
|
|
setLineWidth 1
|
|
-- moveTo x y
|
|
let radius = 20
|
|
let tau = 2 * pi
|
|
arc x y radius 0 tau
|
|
stroke
|
|
|
|
drawNode :: (Int, Element) -> Render ()
|
|
drawNode (elemId, Element {..}) = do
|
|
let (x, y) = _elPosition
|
|
(width, height) = _elSize
|
|
halfWidth = width / 2
|
|
|
|
setSourceRGB 1 0 0
|
|
setLineWidth 1
|
|
rectangle x y halfWidth height
|
|
showText (show elemId)
|
|
stroke
|
|
setSourceRGB 0 1 0
|
|
rectangle (x + halfWidth) y halfWidth height
|
|
stroke
|
|
|
|
updateBackground :: p -> IORef AppState -> Render ()
|
|
updateBackground _canvas 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
|
|
setSourceRGB 0 0 0
|
|
paint
|
|
|
|
stateVal <- liftIO $ readIORef stateRef
|
|
setSourceRGB 1 1 1
|
|
moveTo 10 10
|
|
showText ("fps=" <> show (_asFPSr stateVal))
|
|
setSourceRGB 1 0 0
|
|
traverse_ drawNode (IntMap.toList (_asElements stateVal))
|
|
|
|
findElementByPosition ::
|
|
IntMap.IntMap Element -> (Double, Double) -> Maybe (Int, Element)
|
|
findElementByPosition elements (mouseX, mouseY) =
|
|
let mouseInElement (_elementId, Element {_elPosition, _elSize}) =
|
|
let (x, y) = _elPosition
|
|
(width, height) = _elSize
|
|
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
|
|
|
|
processInputs :: Inputs -> AppState -> AppState
|
|
processInputs
|
|
Inputs {_inEvents}
|
|
oldState@AppState {_asElements, _asMovingNode} =
|
|
let compose = foldr (.) id
|
|
in compose (fmap processInput _inEvents) oldState
|
|
|
|
processInput :: InputEvent -> AppState -> AppState
|
|
processInput inputEvent oldState@AppState {_asElements, _asMovingNode} =
|
|
case inputEvent of
|
|
-- TODO only change movingNode if mouseBtn is leftClick
|
|
ClickOnNode elemId _relativePosition _mouseBtn ->
|
|
let newMovingNodeId = case _asMovingNode of
|
|
Nothing -> Just elemId
|
|
Just _ -> Nothing
|
|
in oldState {_asMovingNode = newMovingNodeId}
|
|
|
|
-- Update the state based on the old state and the mouse
|
|
-- position. Consider moving inputs like mouse position into a
|
|
-- separate input struct.
|
|
updateState :: Inputs -> AppState -> AppState
|
|
updateState
|
|
inputs@Inputs {_inMouseXandY, _inEvents}
|
|
oldState@AppState {_asElements, _asMovingNode} =
|
|
let -- Move the asMovingNode to MouseXandY
|
|
newElements = case _asMovingNode of
|
|
Nothing -> _asElements
|
|
Just nodeId ->
|
|
IntMap.adjust
|
|
( \oldNode@Element {_elPosition, _elSize} ->
|
|
let newX = fst _inMouseXandY - (fst _elSize / 2)
|
|
newY = snd _inMouseXandY - (snd _elSize / 2)
|
|
in oldNode {_elPosition = (newX, newY)}
|
|
)
|
|
(_unElemId nodeId)
|
|
_asElements
|
|
|
|
newState =
|
|
oldState
|
|
{ _asElements = newElements,
|
|
_asFPSr = getFps inputs
|
|
}
|
|
in newState
|
|
|
|
timeoutCallback ::
|
|
IORef Inputs ->
|
|
IORef AppState ->
|
|
Gdk.Window ->
|
|
Gdk.Device ->
|
|
Gtk.DrawingArea ->
|
|
IO Bool
|
|
timeoutCallback inputsRef stateRef gdkWindow device backgroundArea = do
|
|
newTime <- getSystemTime
|
|
gdkDevicePosition <- Gdk.windowGetDevicePositionDouble gdkWindow device
|
|
let (_, x, y, _) = gdkDevicePosition
|
|
|
|
modifyIORef'
|
|
inputsRef
|
|
( \inputs@Inputs {_inTime} ->
|
|
inputs
|
|
{ _inMouseXandY = (x, y),
|
|
_inTime = newTime,
|
|
_inPrevTime = _inTime
|
|
}
|
|
)
|
|
|
|
inputs <- readIORef inputsRef
|
|
|
|
modifyIORef' stateRef (processInputs inputs)
|
|
modifyIORef' stateRef (updateState inputs)
|
|
modifyIORef' inputsRef (\i -> i {_inEvents = []})
|
|
|
|
Gtk.widgetQueueDraw backgroundArea
|
|
pure True
|
|
|
|
startApp :: Gtk.Application -> IO ()
|
|
startApp app = do
|
|
stateRef <- newIORef emptyAppState
|
|
inputsRef <- newIORef emptyInputs
|
|
window <-
|
|
new
|
|
Gtk.ApplicationWindow
|
|
[ #application := app,
|
|
#title := "Glance",
|
|
#defaultWidth := 500,
|
|
#defaultHeight := 500,
|
|
#borderWidth := 0
|
|
]
|
|
backgroundArea <- new Gtk.DrawingArea []
|
|
Gtk.widgetAddEvents
|
|
backgroundArea
|
|
[ Gdk.EventMaskPointerMotionMask,
|
|
Gdk.EventMaskButtonPressMask
|
|
]
|
|
#add window backgroundArea
|
|
|
|
-- geometry <- new Gdk.Geometry [ #minWidth := 500, #minHeight := 500]
|
|
|
|
-- screen <- get window #screen
|
|
-- rgbaVisual <- #getRgbaVisual screen
|
|
-- #setVisual window rgbaVisual
|
|
|
|
-- surfaceRef <- newIORef (Nothing)
|
|
|
|
_ <-
|
|
on
|
|
backgroundArea
|
|
#draw
|
|
( \context -> do
|
|
-- mSurface <- readIORef surfaceRef
|
|
-- surface <- case mSurface of
|
|
-- Nothing -> do
|
|
-- (width, height) <- #getSize window
|
|
-- surf <- createImageSurface
|
|
-- FormatARGB32
|
|
-- (fromIntegral width)
|
|
-- (fromIntegral height)
|
|
-- writeIORef surfaceRef $ Just $ surf
|
|
-- pure surf
|
|
-- Just surface -> pure surface
|
|
|
|
_ <- renderCairo context (updateBackground backgroundArea stateRef)
|
|
pure True
|
|
)
|
|
|
|
#showAll window
|
|
gdkWindow <- fromJust <$> #getWindow window
|
|
display <- fmap fromJust Gdk.displayGetDefault -- TODO unsafe
|
|
deviceManager <- fromJust <$> Gdk.displayGetDeviceManager display -- TODO deprecated
|
|
device <- Gdk.deviceManagerGetClientPointer deviceManager
|
|
_ <-
|
|
GLib.timeoutAdd
|
|
GLib.PRIORITY_DEFAULT
|
|
1
|
|
(timeoutCallback inputsRef stateRef gdkWindow device backgroundArea)
|
|
|
|
let backgroundPress eventButton = do
|
|
mouseBtn <- get eventButton #button
|
|
when
|
|
(mouseBtn == rightMouseButton)
|
|
( do
|
|
(x, y) <- getXandY eventButton
|
|
|
|
modifyIORef'
|
|
stateRef
|
|
( \s@AppState {_asElements} ->
|
|
let key = maybe 0 fst (IntMap.lookupMax _asElements)
|
|
newNode =
|
|
Element
|
|
{ _elPosition = (x, y),
|
|
_elSize = nodeSize,
|
|
_elZ = 0
|
|
}
|
|
newElements =
|
|
IntMap.insert (key + 1) newNode _asElements
|
|
in s {_asElements = newElements}
|
|
)
|
|
pure ()
|
|
)
|
|
when
|
|
(mouseBtn == leftMouseButton)
|
|
( do
|
|
putStrLn "Left click"
|
|
mousePosition <- getXandY eventButton
|
|
|
|
state <- readIORef stateRef
|
|
|
|
modifyIORef'
|
|
inputsRef
|
|
( \s@Inputs {_inEvents} ->
|
|
let mElem =
|
|
findElementByPosition (_asElements state) mousePosition
|
|
in case mElem of
|
|
Nothing -> s
|
|
Just (elemId, element) ->
|
|
let (elementX, elementY) = _elPosition element
|
|
(mouseX, mouseY) = mousePosition
|
|
in s
|
|
{ _inEvents =
|
|
ClickOnNode
|
|
(ElemId elemId)
|
|
(mouseX - elementX, mouseY - elementY)
|
|
mouseBtn :
|
|
_inEvents
|
|
}
|
|
)
|
|
)
|
|
|
|
putStrLn "backgroundPressed"
|
|
pure True
|
|
_ <- on backgroundArea #buttonPressEvent backgroundPress
|
|
|
|
#showAll window
|
|
pure ()
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- new Gtk.Application []
|
|
_ <- on app #activate (startApp app)
|
|
appStatus <- Gio.applicationRun app Nothing
|
|
putStrLn ("Application status is " <> show appStatus)
|
|
pure ()
|