netwire-input-glfw (empty) → 0.0.1

raw patch · 6 files changed

+533/−0 lines, 6 filesdep +GLFW-bdep +basedep +containerssetup-changed

Dependencies added: GLFW-b, base, containers, mtl, netwire-input, stm

Files

LICENSE +20/−0
README.md +5/−0
Setup.hs +2/−0
examples/Cursor.hs +231/−0
lib/FRP/Netwire/Input/GLFW.hs +234/−0
netwire-input-glfw.cabal +41/−0

+ LICENSE view

@@ -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.

+ README.md view

@@ -0,0 +1,5 @@+netwire-input-glfw+============++This library contains the necessary typeclasses to interface with+[netwire-input](https://github.com/Mokosha/netwire-input)

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ examples/Cursor.hs view

@@ -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)

+ lib/FRP/Netwire/Input/GLFW.hs view

@@ -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

+ netwire-input-glfw.cabal view

@@ -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