diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Pavel Krajcevski + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +netwire-input-glfw +============ + +This library contains the necessary typeclasses to interface with +[netwire-input](https://github.com/Mokosha/netwire-input) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Cursor.hs b/examples/Cursor.hs new file mode 100644 --- /dev/null +++ b/examples/Cursor.hs @@ -0,0 +1,231 @@ +module Main where + +-------------------------------------------------------------------------------- +import Control.Monad.State +import Control.Monad.Trans.Class +import Control.Wire hiding (unless) + +import Data.Array.IO +import Data.Array.Storable +import qualified Data.ByteString.Char8 as BS +import Data.List +import Data.Word + +import FRP.Netwire.Input +import FRP.Netwire.Input.GLFW + +import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL as GL + +import Foreign.Storable +import Foreign.Ptr + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- +-- Boilerplate + +data Shape = Shape GL.NumArrayIndices GL.BufferObject GL.BufferObject + +mkCircle :: IO (Shape) +mkCircle = let + slices = 50 + vptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: GL.Vertex2 Float)) + iptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: Int)) + winding = [0,(2*pi/(fromIntegral slices))..] :: [Float] + in do + vbuf <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer GL.$= (Just vbuf) + let vl = (GL.Vertex2 0 0) : (zipWith GL.Vertex2 (map cos winding) (map sin winding)) + verts <- newListArray (0, slices + 1) vl + withStorableArray verts + (\ptr -> GL.bufferData GL.ArrayBuffer GL.$= (vptrsize, ptr, GL.StaticDraw)) + + ibuf <- GL.genObjectName + GL.bindBuffer GL.ElementArrayBuffer GL.$= (Just ibuf) + idxs <- newListArray (0, slices + 1) ([0,1..] :: [Word16]) + withStorableArray idxs + (\ptr -> GL.bufferData GL.ElementArrayBuffer GL.$= (iptrsize, ptr, GL.StaticDraw)) + + return $ Shape (toEnum $ slices + 2) vbuf ibuf + +vertShader :: BS.ByteString +vertShader = BS.pack $ intercalate ['\n'] [ + "attribute vec2 position;", + "uniform vec2 offset;", + "void main() {", + " gl_Position = vec4(offset + 0.1*position, 1.0, 1.0);", + "}"] + +fragShader :: BS.ByteString +fragShader = BS.pack $ intercalate ['\n'] [ + "uniform vec3 color;", + "void main() {", + " gl_FragColor = vec4(color, 1.0);", + "}"] + +compileShader :: GL.ShaderType -> BS.ByteString -> IO (GL.Shader) +compileShader shdrTy src = do + shdr <- GL.createShader shdrTy + GL.shaderSourceBS shdr GL.$= src + GL.compileShader shdr + shaderLog <- GL.get $ GL.shaderInfoLog shdr + unless (shaderLog == []) $ putStrLn shaderLog + return shdr + +mkRenderFunc :: IO (Shape -> GL.Vertex2 Float -> GL.Color3 Float -> IO ()) +mkRenderFunc = do + -- Compile shaders + vshdr <- compileShader GL.VertexShader vertShader + fshdr <- compileShader GL.FragmentShader fragShader + + -- Create program + prg <- GL.createProgram + mapM_ (GL.attachShader prg) [vshdr, fshdr] + GL.linkProgram prg + + -- Find variable locations + colorLoc <- GL.get $ GL.uniformLocation prg "color" + offsetLoc <- GL.get $ GL.uniformLocation prg "offset" + positionLoc <- GL.get $ GL.attribLocation prg "position" + + GL.currentProgram GL.$= Just prg + + -- Define function + return $ \(Shape numIdxs vbo ibo) pos color -> do + + -- Enable buffers + GL.vertexAttribArray positionLoc GL.$= GL.Enabled + + -- Set uniforms + GL.uniform colorLoc GL.$= ((fmap realToFrac color) :: GL.Color3 GL.GLfloat) + GL.uniform offsetLoc GL.$= ((fmap realToFrac pos) :: GL.Vertex2 GL.GLfloat) + + -- Bind buffers + GL.bindBuffer GL.ArrayBuffer GL.$= Just vbo + GL.vertexAttribPointer positionLoc GL.$= + (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (nullPtr :: Ptr Float)) + + GL.bindBuffer GL.ElementArrayBuffer GL.$= Just ibo + + -- Render + GL.drawElements GL.TriangleFan numIdxs GL.UnsignedShort nullPtr + + -- Disable buffers + GL.vertexAttribArray positionLoc GL.$= GL.Disabled + +-------------------------------------------------------------------------------- + +-- Some type synonyms to keep our code clean +type RenderFn = GL.Vertex2 Float -> GL.Color3 Float -> IO () +type GameMonad = GLFWInputT IO +type GameSession = Session IO (Timed Float ()) + +-- This wire produces the position of the circle. It simply follows the mouse cursor +-- but negates the y-value. The origin of the mouse coordinates are in the top left +-- corner of the screen with the y-axis pointing down while the y-axis for rendering +-- points up. +posWire :: Monoid e => Wire s e GameMonad a (GL.Vertex2 Float) +posWire = mouseCursor >>> (second $ arr negate) >>> (arr $ uncurry GL.Vertex2) + +-- This wire produces color for the circle. If the R, G, or B keys are pressed, +-- then the circle will turn red, green, or blue, respectively. Otherwise, +-- the red and green channels of the circle pulsate +colorWire :: (HasTime t s, Monoid e) => Wire s e GameMonad a (GL.Color3 Float) +colorWire = + -- Key pressed means that it will remain this color + (keyPressed GLFW.Key'R >>> (pure $ GL.Color3 1 0 0)) <|> + (keyPressed GLFW.Key'G >>> (pure $ GL.Color3 0 1 0)) <|> + + -- Key debounced means that it will only flash blue for one frame + (keyDebounced GLFW.Key'B >>> (pure $ GL.Color3 0 0 1)) <|> + + -- Otherwise, pulsate based on the amount of time passed + (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1)) + +-- This wire simply takes a vertex position and color and renders according to the +-- passed in renderFn. In reality, this wire doesn't need to be a wire, and could just +-- be a monad to render, but this way we can render what we need without having to +-- go through the plumbing of our main game loop +renderWire :: Monoid e => RenderFn -> Wire s e GameMonad (GL.Vertex2 Float, GL.Color3 Float) () +renderWire rfn = mkGen_ $ \(pos, color) -> lift $ rfn pos color >> (return $ Right ()) + +-- Wire that behaves like the identity wire until Q is pressed, then inhibits forever. +-- We can compose our main gameWire with this wire to simply quit the program when q is pressed +quitWire :: Monoid e => Wire s e GameMonad a a +quitWire = (mkId &&& eventWire) >>> (rSwitch mkId) + where + eventWire :: Monoid e => Wire s e GameMonad a (Event (Wire s e m a a)) + eventWire = (keyPressed GLFW.Key'Q >>> pure mkEmpty >>> now) <|> never + +-- This is our main game wire, it feeds the position and color into the rendering loop +-- and finally quits if q is pressed. +gameWire :: (HasTime t s, Monoid e) => RenderFn -> Wire s e GameMonad a () +gameWire rfn = posWire &&& colorWire >>> (renderWire rfn) >>> quitWire + +run :: GLFW.Window -> GLFWInputControl -> IO () +run win ictl = do + -- initialize the input + ipt <- getInput ictl + + -- load vertex arrays and whatnot for the circle + circle <- mkCircle + + -- load the render function for getting rendering ready + renderFn <- mkRenderFunc + + -- run the game loop + runGame ipt (countSession_ 0.02) (gameWire $ renderFn circle) + where + + -- The game loop takes the current input state, the time session and + -- our main game wire, and simply steps the wire until it inhibits. + runGame ipt sess w = do + + -- Before rendering clear the framebuffer + GL.clearColor GL.$= GL.Color4 0.0 0.0 0.0 1 + GL.clear [GL.ColorBuffer] + + -- Poll the current input + ipt' <- pollGLFW ipt ictl + + -- Figure out our next timestep + (timeState, sess') <- stepSession sess + + -- Since the GameMonad is a 'StateT GLFWInputState m', in order to + -- step the wires, we have to extract the value from our wire. That means + -- that when we runStateT, we will get the results of our wire and a new + -- state (for example if the wire debounced any keys). This is what we pass + -- back to GLFW. + -- renderPrg :: IO ((Either e (), Wire s e GameMonad a ()), GLFWInputState) + let renderPrg = runStateT (stepWire w timeState (Right undefined)) ipt' + + -- Now run the actual IO program to extract the values from it. + ((result, w'), ipt'') <- renderPrg + + -- End of frame cleanup + GL.flush + GLFW.swapBuffers win + + -- Our quit condition is if the OS asked us to quit, or the wire inhibits + -- (i.e. someone hit the Q key) + case result of + Left () -> return () + Right () -> do + q <- GLFW.windowShouldClose win + unless q $ runGame ipt'' sess' w' + +main :: IO () +main = do + -- Setup GLFW + GLFW.init + (Just m) <- GLFW.createWindow 400 400 "Netwire Input Demo" Nothing Nothing + GLFW.makeContextCurrent (Just m) + + -- Hack for retina displays + (szx, szy) <- GLFW.getFramebufferSize m + GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy)) + + -- Run the scene + run m =<< (mkInputControl m) diff --git a/lib/FRP/Netwire/Input/GLFW.hs b/lib/FRP/Netwire/Input/GLFW.hs new file mode 100644 --- /dev/null +++ b/lib/FRP/Netwire/Input/GLFW.hs @@ -0,0 +1,234 @@ +{-| +Module : FRP.Netwire.Input.GLFW +Description : netwire-input instances for use with GLFW +Copyright : (c) Pavel Krajcevski, 2014 +License : MIT +Maintainer : Krajcevski@gmail.com +Stability : experimental +Portability : POSIX + +This module contains data types with instances needed to create wires +that can be used with the netwire-input combinators. In particular, this +package implements 'GLFWInputT' which has instances of 'MonadKeyboard' and +'MonadMouse' + +-} + +module FRP.Netwire.Input.GLFW ( + -- * GLFW Input + + -- ** Basic Input Monad + GLFWInput, + -- ** Monad Transformer + GLFWInputT, + + -- * State Types + GLFWInputControl, GLFWInputState, + getInput, mkInputControl, pollGLFW +) where + +-------------------------------------------------------------------------------- +import qualified Data.Set as Set +import qualified Graphics.UI.GLFW as GLFW +import Control.Applicative +import Control.Concurrent.STM +import Control.Monad.State +import GHC.Float hiding (clamp) + +import FRP.Netwire.Input +-------------------------------------------------------------------------------- + +clamp :: Ord a => a -> a -> a -> a +clamp x a b = if x < a then a else if x > b then b else x + +newRange :: Floating a => a -> (a, a) -> (a, a) -> a +newRange x (omin, omax) (nmin, nmax) = + nmin + (nmax - nmin) * ((x - omin) / (omax - omin)) + +newRangeC :: (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a +newRangeC x o n@(nmin, nmax) = clamp (newRange x o n) nmin nmax + +modeToGLFWMode :: CursorMode -> GLFW.CursorInputMode +modeToGLFWMode CursorMode'Reset = GLFW.CursorInputMode'Disabled +modeToGLFWMode CursorMode'Disabled = GLFW.CursorInputMode'Disabled +modeToGLFWMode CursorMode'Hidden = GLFW.CursorInputMode'Hidden +modeToGLFWMode CursorMode'Enabled = GLFW.CursorInputMode'Normal + +-- | The GLFW input state is a record that keeps track of which buttons and keys +-- are currently pressed. Because GLFW works with callbacks, a call to pollEvents +-- must be made in order to process any of the events. At this time, all of the +-- appropriate callbacks are fired in order of the events received, and this record +-- is updated to reflect the most recent input state. +data GLFWInputState = GLFWInputState { + keysPressed :: Set.Set GLFW.Key, + mbPressed :: Set.Set GLFW.MouseButton, + cursorPos :: (Float, Float), + cmode :: CursorMode, + scrollAmt :: (Double, Double) +} deriving(Show) + +instance Key GLFW.Key +instance MouseButton GLFW.MouseButton + +-- !FIXME! Perhaps this is better in its own newtype + +-- | The 'GLFWInput' monad is simply a state monad around the GLFWInputState +type GLFWInput = State GLFWInputState + +-- | The 'GLFWInputT' monad transformer is simply a state monad transformer using +-- 'GLFWInputState' +type GLFWInputT m = StateT GLFWInputState m + +instance (Functor m, Monad m) => + MonadKeyboard GLFW.Key (StateT GLFWInputState m) where + + keyIsPressed :: GLFW.Key -> StateT GLFWInputState m Bool + keyIsPressed key = get >>= (return . isKeyPressed key) + + releaseKey :: GLFW.Key -> StateT GLFWInputState m () + releaseKey key = get >>= (put . debounceKey key) + +instance (Functor m, Monad m) => + MonadMouse GLFW.MouseButton (StateT GLFWInputState m) where + + mbIsPressed :: GLFW.MouseButton -> StateT GLFWInputState m Bool + mbIsPressed mb = get >>= (return . isButtonPressed mb) + + releaseButton :: GLFW.MouseButton -> StateT GLFWInputState m () + releaseButton mb = get >>= (put . debounceButton mb) + + cursor :: StateT GLFWInputState m (Float, Float) + cursor = get >>= (return . cursorPos) + + setCursorMode :: CursorMode -> StateT GLFWInputState m () + setCursorMode mode = do + ipt <- get + put (ipt { cmode = mode }) + + scroll :: StateT GLFWInputState m (Double, Double) + scroll = get >>= (return . scrollAmt) + +kEmptyInput :: GLFWInputState +kEmptyInput = GLFWInputState { keysPressed = Set.empty, + mbPressed = Set.empty, + cursorPos = (0, 0), + cmode = CursorMode'Enabled, + scrollAmt = (0, 0) } + +isKeyPressed :: GLFW.Key -> GLFWInputState -> Bool +isKeyPressed key = (Set.member key) . keysPressed + +withPressedKey :: GLFWInputState -> GLFW.Key -> (a -> a) -> a -> a +withPressedKey input key fn = if isKeyPressed key input then fn else id + +debounceKey :: GLFW.Key -> GLFWInputState -> GLFWInputState +debounceKey key = (\input -> input { keysPressed = Set.delete key (keysPressed input) }) + +isButtonPressed :: GLFW.MouseButton -> GLFWInputState -> Bool +isButtonPressed mb = (Set.member mb) . mbPressed + +withPressedButton :: GLFWInputState -> GLFW.MouseButton -> (a -> a) -> a -> a +withPressedButton input mb fn = if isButtonPressed mb input then fn else id + +debounceButton :: GLFW.MouseButton -> GLFWInputState -> GLFWInputState +debounceButton mb = (\input -> input { mbPressed = Set.delete mb (mbPressed input) }) + +-- | This is an 'STM' variable that holds the current input state. It cannot be +-- manipulated directly, but it is updated by GLFW each time 'pollGLFW' is called. +data GLFWInputControl = IptCtl (TVar GLFWInputState) GLFW.Window + +setCursorToWindowCenter :: GLFW.Window -> IO () +setCursorToWindowCenter win = do + (w, h) <- GLFW.getWindowSize win + GLFW.setCursorPos win (fromIntegral w / 2.0) (fromIntegral h / 2.0) + +-- | Returns a current snapshot of the input +getInput :: GLFWInputControl -> IO(GLFWInputState) +getInput (IptCtl var _) = readTVarIO var + +setInput :: GLFWInputControl -> GLFWInputState -> IO () +setInput (IptCtl var win) ipt = do + + -- Do we need to change the cursor mode? + curMode <- GLFW.getCursorInputMode win + let newMode = modeToGLFWMode (cmode ipt) + if newMode == curMode + then return () + else GLFW.setCursorInputMode win newMode + + -- Write the new input + atomically $ writeTVar var (ipt { scrollAmt = (0, 0) }) + +resetCursorPos :: GLFWInputState -> GLFWInputState +resetCursorPos = (\input -> input { cursorPos = (0, 0) }) + +-------------------------- + +scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO () +scrollCallback (IptCtl ctl _) _ xoff yoff = atomically $ modifyTVar' ctl updateScroll + where + updateScroll :: GLFWInputState -> GLFWInputState + updateScroll = (\input -> input { scrollAmt = (xoff, yoff) }) + +keyCallback :: GLFWInputControl -> GLFW.Window -> + GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () +keyCallback (IptCtl ctl _) _ key _ keystate _ = atomically $ modifyTVar' ctl modifyKeys + where + updateKeys :: (Set.Set GLFW.Key -> Set.Set GLFW.Key) -> GLFWInputState -> GLFWInputState + updateKeys fn = (\input -> input { keysPressed = fn (keysPressed input) }) + + modifyKeys :: GLFWInputState -> GLFWInputState + modifyKeys = case keystate of + GLFW.KeyState'Pressed -> updateKeys $ Set.insert key + GLFW.KeyState'Released -> updateKeys $ Set.delete key + _ -> id + +mouseButtonCallback :: GLFWInputControl -> GLFW.Window -> + GLFW.MouseButton -> GLFW.MouseButtonState -> + GLFW.ModifierKeys -> IO () +mouseButtonCallback (IptCtl ctl _) _ button state _ = + atomically $ modifyTVar' ctl modify + where + update :: (Set.Set GLFW.MouseButton -> Set.Set GLFW.MouseButton) -> + GLFWInputState -> GLFWInputState + update fn = (\ipt -> ipt { mbPressed = fn (mbPressed ipt) }) + + modify :: GLFWInputState -> GLFWInputState + modify = case state of + GLFW.MouseButtonState'Pressed -> update $ Set.insert button + GLFW.MouseButtonState'Released -> update $ Set.delete button + +cursorPosCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO () +cursorPosCallback (IptCtl ctl _) win x y = do + (w, h) <- GLFW.getWindowSize win + let xf = newRangeC (double2Float x) (0, fromIntegral w) (-1, 1) + yf = newRangeC (double2Float y) (0, fromIntegral h) (-1, 1) + atomically $ modifyTVar' ctl (\ipt -> ipt { cursorPos = (xf, yf)}) + +-- | Creates and returns an 'STM' variable for the window that holds all of the +-- most recent input state information +mkInputControl :: GLFW.Window -> IO (GLFWInputControl) +mkInputControl win = do + ctlvar <- newTVarIO kEmptyInput + let ctl = IptCtl ctlvar win + GLFW.setScrollCallback win (Just $ scrollCallback ctl) + GLFW.setKeyCallback win (Just $ keyCallback ctl) + GLFW.setCursorPosCallback win (Just $ cursorPosCallback ctl) + GLFW.setMouseButtonCallback win (Just $ mouseButtonCallback ctl) + return ctl + +-- | Allows GLFW to interact with the windowing system to update the current +-- state. The old state must be passed in order to properly reset certain +-- properties such as the scroll wheel. The returned input state is identical +-- to a subsequent call to 'getInput' right after a call to 'GLFW.pollEvents' +pollGLFW :: GLFWInputState -> GLFWInputControl -> IO (GLFWInputState) +pollGLFW ipt iptctl@(IptCtl _ win) = do + -- Do we need to reset the cursor? + if (cmode ipt) == CursorMode'Reset + then do + setCursorToWindowCenter win + setInput iptctl (resetCursorPos ipt) + else setInput iptctl ipt + + GLFW.pollEvents + getInput iptctl diff --git a/netwire-input-glfw.cabal b/netwire-input-glfw.cabal new file mode 100644 --- /dev/null +++ b/netwire-input-glfw.cabal @@ -0,0 +1,41 @@ +-- Initial netwire-input-glfw.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: netwire-input-glfw +version: 0.0.1 +synopsis: GLFW instance of netwire-input +description: This package contains the necessary glue to allow the use + of wires from the netwire-input package. In general, the types + associated here should be used only sparingly to plumb the input + state through your netwire program. Otherwise, the state should + not be modified directly. +homepage: https://www.github.com/Mokosha/netwire-input-glfw +license: MIT +license-file: LICENSE +author: Pavel Krajcevski +maintainer: Krajcevski@gmail.com +copyright: Pavel Krajcevski, 2014 +category: Game +build-type: Simple +extra-source-files: examples/Cursor.hs README.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/Mokosha/netwire-input-glfw + +library + default-extensions: FlexibleInstances, + TypeSynonymInstances, + MultiParamTypeClasses, + InstanceSigs + exposed-modules: FRP.Netwire.Input.GLFW + -- other-modules: + build-depends: base >=4.7 && <4.8, + netwire-input, + containers, + GLFW-b, + stm, + mtl + hs-source-dirs: lib + default-language: Haskell2010