aztecs-glfw (empty) → 0.1.0

raw patch · 6 files changed

+271/−0 lines, 6 filesdep +GLFW-bdep +aztecsdep +aztecs-glfw

Dependencies added: GLFW-b, aztecs, aztecs-glfw, base, containers

Files

CHANGELOG.md +5/−0
LICENSE +29/−0
app/Main.hs +29/−0
aztecs-glfw.cabal +48/−0
src/Aztecs/GLFW.hs +156/−0
test/Main.hs +4/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for aztecs-glfw
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright (c) 2026, Matt Hunzinger
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ app/Main.hs view

@@ -0,0 +1,29 @@+module Main where++import Aztecs+import Aztecs.GLFW+import Control.Monad.IO.Class+import System.IO+import Prelude hiding (lookup)++main :: IO ()+main = runAccess_ $ do+  e <-+    spawn $+      bundle $+        Window+          { windowTitle = "Aztecs GLFW Window",+            windowWidth = 800,+            windowHeight = 600+          }+  runAccessGLFW $ do+    res <- lookup e+    case res of+      Just keys ->+        if keyJustPressed Key'Escape keys+          then liftIO $ do+            putStrLn "Escape key just pressed, exiting..."+            hFlush stdout+            return True+          else return False+      Nothing -> return False

+ aztecs-glfw.cabal view

@@ -0,0 +1,48 @@+cabal-version:   3.0+name:            aztecs-glfw+version:         0.1.0+license:         BSD-3-Clause+license-file:    LICENSE+maintainer:      matt@hunzinger.me+author:          Matt Hunzinger+homepage:        https://github.com/aztecs-hs/aztecs+synopsis:        GLFW backed for Aztecs+description:     GLFW backend for the Aztecs game engine and ECS+category:        Game Engine+build-type:      Simple+extra-doc-files: CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/aztecs-hs/aztecs-glfw.git++library+    exposed-modules:  Aztecs.GLFW+    hs-source-dirs:   src+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.2 && <5,+        aztecs >=0.16.1,+        containers >=0.7,+        GLFW-b >=3++executable aztecs-glfw+    main-is:          Main.hs+    hs-source-dirs:   app+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.2 && <5,+        aztecs-glfw,+        aztecs++test-suite aztecs-glfw-test+    type:             exitcode-stdio-1.0+    main-is:          Main.hs+    hs-source-dirs:   test+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base >=4.2 && <5,+        aztecs-glfw

+ src/Aztecs/GLFW.hs view

@@ -0,0 +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')

+ test/Main.hs view

@@ -0,0 +1,4 @@+module Main (main) where++main :: IO ()+main = putStrLn "Test suite not yet implemented."