diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for aztecs-glfw + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/aztecs-glfw.cabal b/aztecs-glfw.cabal new file mode 100644 --- /dev/null +++ b/aztecs-glfw.cabal @@ -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 diff --git a/src/Aztecs/GLFW.hs b/src/Aztecs/GLFW.hs new file mode 100644 --- /dev/null +++ b/src/Aztecs/GLFW.hs @@ -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') diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented."