aztecs-glfw 0.1.0 → 0.2.0

raw patch · 2 files changed

+157/−157 lines, 2 files

Files

• aztecs-glfw.cabal +1/−1
• src/Aztecs/GLFW.hs +156/−156

@@ -1,6 +1,6 @@ cabal-version:   3.0 name:            aztecs-glfw-version:         0.1.0+version:         0.2.0 license:         BSD-3-Clause license-file:    LICENSE maintainer:      matt@hunzinger.me

@@ -1,156 +1,156 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeApplications #-}--module Aztecs.GLFW-  ( Key (..),-    Keys (..),-    keyPressed,-    keyJustPressed,-    keyJustUnpressed,-    Cursor (..),-    Window (..),-    RawWindow (..),-    runAccessGLFW,-  )-where--import Aztecs-import Control.Monad-import Control.Monad.IO.Class-import Data.IORef-import Data.Set (Set)-import qualified Data.Set as Set-import Graphics.UI.GLFW (Key (..))-import qualified Graphics.UI.GLFW as GLFW-import Prelude hiding (lookup)--type KeySet = Set Key--data KeyStates = KeyStates-  { keysJustPressed :: KeySet,-    keysJustUnpressed :: KeySet-  }-  deriving (Show, Eq)--instance Monoid KeyStates where-  mempty = KeyStates Set.empty Set.empty--instance Semigroup KeyStates where-  (KeyStates p1 u1) <> (KeyStates p2 u2) = KeyStates (p1 <> p2) (u1 <> u2)---- | Raw window component-data RawWindow = RawWindow-  { unRawWindow :: GLFW.Window,-    rawWindowKeyStates :: IORef KeyStates-  }--instance (Monad m) => Component m RawWindow---- | Keys component-data Keys = Keys-  { keysPressed :: KeySet,-    keyStates :: KeyStates-  }-  deriving (Show, Eq)--instance Monoid Keys where-  mempty = Keys Set.empty mempty--instance Semigroup Keys where-  (Keys p1 ks1) <> (Keys p2 ks2) = Keys (p1 <> p2) (ks1 <> ks2)--instance (Monad m) => Component m Keys--keyPressed :: Key -> Keys -> Bool-keyPressed k ks = k `Set.member` keysPressed ks--keyJustPressed :: Key -> Keys -> Bool-keyJustPressed k ks = k `Set.member` (keysJustPressed . keyStates $ ks)--keyJustUnpressed :: Key -> Keys -> Bool-keyJustUnpressed k ks = k `Set.member` (keysJustUnpressed . keyStates $ ks)---- | Cursor component-data Cursor = Cursor-  { cursorX :: Double,-    cursorY :: Double-  }-  deriving (Show, Eq)--instance (Monad m) => Component m Cursor---- | Window component-data Window = Window-  { windowTitle :: String,-    windowWidth :: Int,-    windowHeight :: Int-  }-  deriving (Show, Eq)--instance (MonadIO m) => Component m Window where-  componentOnInsert e w = do-    insert e $ bundle (mempty @Keys) <> bundle (Cursor 0 0)-    res <- liftIO $ do-      _ <- GLFW.init-      res <- GLFW.createWindow (windowWidth w) (windowHeight w) (windowTitle w) Nothing Nothing-      case res of-        Nothing -> return Nothing-        Just raw -> do-          keyStatesRef <- newIORef $ KeyStates Set.empty Set.empty-          GLFW.setKeyCallback raw $ Just (go keyStatesRef)-          return . Just $ RawWindow raw keyStatesRef-    case res of-      Just raw -> insert e . bundle $ raw-      Nothing -> error "TODO"-    where-      go keyStatesRef _win key _scancode action _mods = do-        when (action == GLFW.KeyState'Pressed) $ do-          modifyIORef keyStatesRef (\ks -> ks {keysJustPressed = Set.insert key (keysJustPressed ks)})-        when (action == GLFW.KeyState'Released) $ do-          modifyIORef keyStatesRef (\ks -> ks {keysJustUnpressed = Set.insert key (keysJustUnpressed ks)})-  componentOnChange e w w' = do-    when (windowTitle w /= windowTitle w') $ do-      mws <- lookup e-      case mws of-        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowTitle raw (windowTitle w')-        Nothing -> return ()-    when ((windowWidth w, windowHeight w) /= (windowWidth w', windowHeight w')) $ do-      mws <- lookup e-      case mws of-        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowSize raw (windowWidth w') (windowHeight w')-        Nothing -> return ()-  componentOnRemove e _ = do-    mws <- lookup e-    case mws of-      Just (RawWindow raw _) -> liftIO $ GLFW.destroyWindow raw-      Nothing -> return ()--runAccessGLFW :: Access IO Bool -> Access IO ()-runAccessGLFW a = do-  liftIO $ GLFW.pollEvents-  shouldClose <- a-  if shouldClose-    then return ()-    else do-      res <- system . runQuery . queryUntracked . queryMapWithAccumM go' $ queryMapWithAccumM go query-      unless (or $ fmap fst res) $ runAccessGLFW a-  where-    go (RawWindow rw keyStatesRef) cursor = liftIO $ do-      (x, y) <- GLFW.getCursorPos rw-      let cursor' = cursor {cursorX = x, cursorY = y}-      return (RawWindow rw keyStatesRef, cursor')-    go' (RawWindow rw keyStatesRef, _) keys = liftIO $ do-      ks <- readIORef keyStatesRef-      writeIORef keyStatesRef mempty--      let newPressed = (keysPressed keys `Set.union` keysJustPressed ks) `Set.difference` keysJustUnpressed ks-      let keys' =-            Keys-              { keysPressed = newPressed,-                keyStates = ks-              }--      shouldClose <- GLFW.windowShouldClose rw-      GLFW.swapBuffers rw-      return (shouldClose, keys')+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Aztecs.GLFW
+  ( Key (..),
+    Keys (..),
+    keyPressed,
+    keyJustPressed,
+    keyJustUnpressed,
+    Cursor (..),
+    Window (..),
+    RawWindow (..),
+    runAccessGLFW,
+  )
+where
+
+import Aztecs
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.IORef
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Graphics.UI.GLFW (Key (..))
+import qualified Graphics.UI.GLFW as GLFW
+import Prelude hiding (lookup)
+
+type KeySet = Set Key
+
+data KeyStates = KeyStates
+  { keysJustPressed :: KeySet,
+    keysJustUnpressed :: KeySet
+  }
+  deriving (Show, Eq)
+
+instance Monoid KeyStates where
+  mempty = KeyStates Set.empty Set.empty
+
+instance Semigroup KeyStates where
+  (KeyStates p1 u1) <> (KeyStates p2 u2) = KeyStates (p1 <> p2) (u1 <> u2)
+
+-- | Raw window component
+data RawWindow = RawWindow
+  { unRawWindow :: GLFW.Window,
+    rawWindowKeyStates :: IORef KeyStates
+  }
+
+instance (Monad m) => Component m RawWindow
+
+-- | Keys component
+data Keys = Keys
+  { keysPressed :: KeySet,
+    keyStates :: KeyStates
+  }
+  deriving (Show, Eq)
+
+instance Monoid Keys where
+  mempty = Keys Set.empty mempty
+
+instance Semigroup Keys where
+  (Keys p1 ks1) <> (Keys p2 ks2) = Keys (p1 <> p2) (ks1 <> ks2)
+
+instance (Monad m) => Component m Keys
+
+keyPressed :: Key -> Keys -> Bool
+keyPressed k ks = k `Set.member` keysPressed ks
+
+keyJustPressed :: Key -> Keys -> Bool
+keyJustPressed k ks = k `Set.member` (keysJustPressed . keyStates $ ks)
+
+keyJustUnpressed :: Key -> Keys -> Bool
+keyJustUnpressed k ks = k `Set.member` (keysJustUnpressed . keyStates $ ks)
+
+-- | Cursor component
+data Cursor = Cursor
+  { cursorX :: Double,
+    cursorY :: Double
+  }
+  deriving (Show, Eq)
+
+instance (Monad m) => Component m Cursor
+
+-- | Window component
+data Window = Window
+  { windowTitle :: String,
+    windowWidth :: Int,
+    windowHeight :: Int
+  }
+  deriving (Show, Eq)
+
+instance (MonadIO m) => Component m Window where
+  componentOnInsert e w = do
+    insert e $ bundle (mempty @Keys) <> bundle (Cursor 0 0)
+    res <- liftIO $ do
+      _ <- GLFW.init
+      res <- GLFW.createWindow (windowWidth w) (windowHeight w) (windowTitle w) Nothing Nothing
+      case res of
+        Nothing -> return Nothing
+        Just raw -> do
+          keyStatesRef <- newIORef $ KeyStates Set.empty Set.empty
+          GLFW.setKeyCallback raw $ Just (go keyStatesRef)
+          return . Just $ RawWindow raw keyStatesRef
+    case res of
+      Just raw -> insert e . bundle $ raw
+      Nothing -> error "TODO"
+    where
+      go keyStatesRef _win key _scancode action _mods = do
+        when (action == GLFW.KeyState'Pressed) $ do
+          modifyIORef keyStatesRef (\ks -> ks {keysJustPressed = Set.insert key (keysJustPressed ks)})
+        when (action == GLFW.KeyState'Released) $ do
+          modifyIORef keyStatesRef (\ks -> ks {keysJustUnpressed = Set.insert key (keysJustUnpressed ks)})
+  componentOnChange e w w' = do
+    when (windowTitle w /= windowTitle w') $ do
+      mws <- lookup e
+      case mws of
+        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowTitle raw (windowTitle w')
+        Nothing -> return ()
+    when ((windowWidth w, windowHeight w) /= (windowWidth w', windowHeight w')) $ do
+      mws <- lookup e
+      case mws of
+        Just (RawWindow raw _) -> liftIO $ GLFW.setWindowSize raw (windowWidth w') (windowHeight w')
+        Nothing -> return ()
+  componentOnRemove e _ = do
+    mws <- lookup e
+    case mws of
+      Just (RawWindow raw _) -> liftIO $ GLFW.destroyWindow raw
+      Nothing -> return ()
+
+runAccessGLFW :: (MonadIO m) => Access m Bool -> Access m ()
+runAccessGLFW a = do
+  liftIO $ GLFW.pollEvents
+  shouldClose <- a
+  if shouldClose
+    then return ()
+    else do
+      res <- system . runQuery . queryUntracked . queryMapWithAccumM go' $ queryMapWithAccumM go query
+      unless (or $ fmap fst res) $ runAccessGLFW a
+  where
+    go (RawWindow rw keyStatesRef) cursor = liftIO $ do
+      (x, y) <- GLFW.getCursorPos rw
+      let cursor' = cursor {cursorX = x, cursorY = y}
+      return (RawWindow rw keyStatesRef, cursor')
+    go' (RawWindow rw keyStatesRef, _) keys = liftIO $ do
+      ks <- readIORef keyStatesRef
+      writeIORef keyStatesRef mempty
+
+      let newPressed = (keysPressed keys `Set.union` keysJustPressed ks) `Set.difference` keysJustUnpressed ks
+      let keys' =
+            Keys
+              { keysPressed = newPressed,
+                keyStates = ks
+              }
+
+      shouldClose <- GLFW.windowShouldClose rw
+      GLFW.swapBuffers rw
+      return (shouldClose, keys')