diff --git a/GLFW-b-demo.cabal b/GLFW-b-demo.cabal --- a/GLFW-b-demo.cabal +++ b/GLFW-b-demo.cabal @@ -1,49 +1,52 @@ -name: GLFW-b-demo -version: 0.1.1 - -category: Graphics - -synopsis: GLFW-b test\/example\/demo -description: GLFW-b test\/example\/demo. - . - Run 'GLFW-b-demo' and use a joystick or cursor keys to rotate an - RGB cube. /Please help me think of more interesting stuff to do/ - /in here./ +name: GLFW-b-demo +version: 1.0.0 -author: Brian Lewis -maintainer: Brian Lewis +author: Brian Lewis +maintainer: Brian Lewis -license: BSD3 -license-file: LICENSE +category: Graphics +synopsis: GLFW-b demo +description: + This is a demonstration of + allowing the user to interact with colorful spinning gears using cursor keys, + mouse, scroll wheel, and joystick. + . + Here's a . --- -- -- -- -- -- -- -- -- -- +license: BSD3 +license-file: LICENSE -cabal-version: >= 1.6 +cabal-version: >= 1.10 build-type: Simple --- -- -- -- -- -- -- -- -- -- +-------------------------------------------------------------------------------- extra-source-files: - src/Cube.hs - src/Display.hs + README.md + TODO +-------------------------------------------------------------------------------- + executable GLFW-b-demo - main-is: Main.hs + default-language: Haskell2010 - hs-source-dirs: - src + hs-source-dirs: src + main-is: Main.hs build-depends: - GLFW-b == 0.*, - OpenGL == 2.6.*, - GLURaw == 1.3.*, - base == 4.* + GLFW-b == 1.0.*, + OpenGL == 2.8.*, + base < 5, + mtl == 2.1.*, + pretty == 1.1.*, + stm == 2.4.*, + transformers == 0.3.* ghc-options: -Wall -O2 if impl(ghc >= 6.8) ghc-options: -fwarn-tabs --- -- -- -- -- -- -- -- -- -- +-------------------------------------------------------------------------------- source-repository head type: git diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Brian Lewis 2010 +Copyright Brian Lewis 2013 All rights reserved. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +This is a demonstration of [GLFW-b][1] allowing the user to interact with +spinning gears using cursor keys, mouse, scroll wheel, and joystick. + +Here's a [screenshot][2]. + +[1]: https://github.com/bsl/GLFW-b +[2]: http://i.imgur.com/JZKwVSu.png diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,13 @@ +Is TChan a sensible choice of chan for events? Should there be some interface +for subscribing to events by type that registers and unregisters callbacks as +needed? + +Figure out what rotation should actually result from up, down, etc., and be +consistent across keyboard, mouse, joystick. For example, left and right should +produce a y-axis rotation. But what do negative and positive rotation mean in +OpenGL? + +Find pain points in implementation and use them for inspiration for +higher-level API and/or utility functions. +1.) The directional pad on my PS3 controller corresponds to buttons 4..7 for + up, right, down, left. It's annoying to extract just those. diff --git a/src/Cube.hs b/src/Cube.hs deleted file mode 100644 --- a/src/Cube.hs +++ /dev/null @@ -1,62 +0,0 @@ -module Cube - ( draw - ) where - -import qualified Graphics.Rendering.OpenGL as GL - -draw :: GL.GLfloat -> IO () -draw s = do - GL.scale s s s - GL.renderPrimitive GL.Quads $ do - -- front - GL.color red - GL.normal (GL.Normal3 z z p1) - GL.vertex (GL.Vertex3 n1 n1 p1) - GL.vertex (GL.Vertex3 p1 n1 p1) - GL.vertex (GL.Vertex3 p1 p1 p1) - GL.vertex (GL.Vertex3 n1 p1 p1) - -- back - GL.color red - GL.normal (GL.Normal3 z z n1) - GL.vertex (GL.Vertex3 n1 n1 n1) - GL.vertex (GL.Vertex3 n1 p1 n1) - GL.vertex (GL.Vertex3 p1 p1 n1) - GL.vertex (GL.Vertex3 p1 n1 n1) - -- top - GL.color green - GL.normal (GL.Normal3 z p1 z) - GL.vertex (GL.Vertex3 n1 p1 n1) - GL.vertex (GL.Vertex3 n1 p1 p1) - GL.vertex (GL.Vertex3 p1 p1 p1) - GL.vertex (GL.Vertex3 p1 p1 n1) - -- bottom - GL.color green - GL.normal (GL.Normal3 z n1 z) - GL.vertex (GL.Vertex3 n1 n1 n1) - GL.vertex (GL.Vertex3 p1 n1 n1) - GL.vertex (GL.Vertex3 p1 n1 p1) - GL.vertex (GL.Vertex3 n1 n1 p1) - -- right - GL.color blue - GL.normal (GL.Normal3 p1 z z) - GL.vertex (GL.Vertex3 p1 n1 n1) - GL.vertex (GL.Vertex3 p1 p1 n1) - GL.vertex (GL.Vertex3 p1 p1 p1) - GL.vertex (GL.Vertex3 p1 n1 p1) - -- left - GL.color blue - GL.normal (GL.Normal3 n1 z z) - GL.vertex (GL.Vertex3 n1 n1 n1) - GL.vertex (GL.Vertex3 n1 n1 p1) - GL.vertex (GL.Vertex3 n1 p1 p1) - GL.vertex (GL.Vertex3 n1 p1 n1) - -red, green, blue :: GL.Color4 GL.GLfloat -red = GL.Color4 1 0 0 1 -green = GL.Color4 0 1 0 1 -blue = GL.Color4 0 0 1 1 - -z, n1, p1 :: GL.GLfloat -z = 0 -n1 = -1 -p1 = 1 diff --git a/src/Display.hs b/src/Display.hs deleted file mode 100644 --- a/src/Display.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Display - ( draw - ) where - -import qualified Cube - -import qualified Graphics.Rendering.OpenGL as GL -import qualified Graphics.UI.GLFW as GLFW - -draw :: Float -> Float -> IO () -draw xa ya = do - GL.clear [GL.ColorBuffer, GL.DepthBuffer] - GL.loadIdentity - - GL.preservingMatrix $ do - GL.rotate (realToFrac xa) xVector3 - GL.rotate (realToFrac ya) yVector3 - Cube.draw w - - GLFW.swapBuffers - where - xVector3 = GL.Vector3 1 0 0 :: GL.Vector3 GL.GLfloat - yVector3 = GL.Vector3 0 1 0 :: GL.Vector3 GL.GLfloat - w = 0.5 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,100 +1,606 @@ module Main (main) where -import Control.Monad (liftM, unless, when) +-------------------------------------------------------------------------------- -import qualified Graphics.Rendering.GLU.Raw as GLU -import qualified Graphics.Rendering.OpenGL as GL +import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue) +import Control.Monad (unless, when, void) +import Control.Monad.RWS.Strict (RWST, ask, asks, evalRWST, get, liftIO, modify, put) +import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT) +import Data.List (intercalate) +import Data.Maybe (catMaybes) +import Text.PrettyPrint -import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.UI.GLFW as GLFW -import qualified Display +import Gear (makeGear) +-------------------------------------------------------------------------------- + +data Env = Env + { envEventsChan :: TQueue Event + , envWindow :: !GLFW.Window + , envGear1 :: !GL.DisplayList + , envGear2 :: !GL.DisplayList + , envGear3 :: !GL.DisplayList + , envZDistClosest :: !Double + , envZDistFarthest :: !Double + } + +data State = State + { stateWindowWidth :: !Int + , stateWindowHeight :: !Int + , stateXAngle :: !Double + , stateYAngle :: !Double + , stateZAngle :: !Double + , stateGearZAngle :: !Double + , stateZDist :: !Double + , stateMouseDown :: !Bool + , stateDragging :: !Bool + , stateDragStartX :: !Double + , stateDragStartY :: !Double + , stateDragStartXAngle :: !Double + , stateDragStartYAngle :: !Double + } + +type Demo = RWST Env () State IO + +-------------------------------------------------------------------------------- + +data Event = + EventError !GLFW.Error !String + | EventWindowPos !GLFW.Window !Int !Int + | EventWindowSize !GLFW.Window !Int !Int + | EventWindowClose !GLFW.Window + | EventWindowRefresh !GLFW.Window + | EventWindowFocus !GLFW.Window !GLFW.FocusState + | EventWindowIconify !GLFW.Window !GLFW.IconifyState + | EventFramebufferSize !GLFW.Window !Int !Int + | EventMouseButton !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys + | EventCursorPos !GLFW.Window !Double !Double + | EventCursorEnter !GLFW.Window !GLFW.CursorState + | EventScroll !GLFW.Window !Double !Double + | EventKey !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys + | EventChar !GLFW.Window !Char + deriving Show + +-------------------------------------------------------------------------------- + main :: IO () main = do - configureDisplay - start - stop + let width = 640 + height = 480 -configureDisplay :: IO () -configureDisplay = do - _ <- GLFW.initialize + eventsChan <- newTQueueIO :: IO (TQueue Event) - _ <- GLFW.openWindow GLFW.defaultDisplayOptions - { GLFW.displayOptions_numRedBits = 8 - , GLFW.displayOptions_numGreenBits = 8 - , GLFW.displayOptions_numBlueBits = 8 - , GLFW.displayOptions_numDepthBits = 1 + withWindow width height "GLFW-b-demo" $ \win -> do + GLFW.setErrorCallback $ Just $ errorCallback eventsChan + GLFW.setWindowPosCallback win $ Just $ windowPosCallback eventsChan + GLFW.setWindowSizeCallback win $ Just $ windowSizeCallback eventsChan + GLFW.setWindowCloseCallback win $ Just $ windowCloseCallback eventsChan + GLFW.setWindowRefreshCallback win $ Just $ windowRefreshCallback eventsChan + GLFW.setWindowFocusCallback win $ Just $ windowFocusCallback eventsChan + GLFW.setWindowIconifyCallback win $ Just $ windowIconifyCallback eventsChan + GLFW.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan + GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback eventsChan + GLFW.setCursorPosCallback win $ Just $ cursorPosCallback eventsChan + GLFW.setCursorEnterCallback win $ Just $ cursorEnterCallback eventsChan + GLFW.setScrollCallback win $ Just $ scrollCallback eventsChan + GLFW.setKeyCallback win $ Just $ keyCallback eventsChan + GLFW.setCharCallback win $ Just $ charCallback eventsChan + + GLFW.swapInterval 1 + + GL.position (GL.Light 0) GL.$= GL.Vertex4 5 5 10 0 + GL.light (GL.Light 0) GL.$= GL.Enabled + GL.lighting GL.$= GL.Enabled + GL.cullFace GL.$= Just GL.Back + GL.depthFunc GL.$= Just GL.Less + GL.clearColor GL.$= GL.Color4 0.05 0.05 0.05 1 + GL.normalize GL.$= GL.Enabled + + gear1 <- makeGear 1 4 1 20 0.7 (GL.Color4 0.8 0.1 0 1) -- red + gear2 <- makeGear 0.5 2 2 10 0.7 (GL.Color4 0 0.8 0.2 1) -- green + gear3 <- makeGear 1.3 2 0.5 10 0.7 (GL.Color4 0.2 0.2 1 1) -- blue + + let zDistClosest = 10 + zDistFarthest = zDistClosest + 20 + zDist = zDistClosest + ((zDistFarthest - zDistClosest) / 2) + env = Env + { envEventsChan = eventsChan + , envWindow = win + , envGear1 = gear1 + , envGear2 = gear2 + , envGear3 = gear3 + , envZDistClosest = zDistClosest + , envZDistFarthest = zDistFarthest + } + state = State + { stateWindowWidth = width + , stateWindowHeight = height + , stateXAngle = 0 + , stateYAngle = 0 + , stateZAngle = 0 + , stateGearZAngle = 0 + , stateZDist = zDist + , stateMouseDown = False + , stateDragging = False + , stateDragStartX = 0 + , stateDragStartY = 0 + , stateDragStartXAngle = 0 + , stateDragStartYAngle = 0 + } + runDemo env state + + putStrLn "ended!" + +-------------------------------------------------------------------------------- + +-- GLFW-b is made to be very close to the C API, so creating a window is pretty +-- clunky by Haskell standards. A higher-level API would have some function +-- like withWindow. + +withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO () +withWindow width height title f = do + GLFW.setErrorCallback $ Just simpleErrorCallback + r <- GLFW.init + when r $ do + m <- GLFW.createWindow width height title Nothing Nothing + case m of + (Just win) -> do + GLFW.makeContextCurrent m + f win + GLFW.setErrorCallback $ Just simpleErrorCallback + GLFW.destroyWindow win + Nothing -> return () + GLFW.terminate + where + simpleErrorCallback e s = + putStrLn $ unwords [show e, show s] + +-------------------------------------------------------------------------------- + +-- Each callback does just one thing: write an appropriate Event to the events +-- TQueue. + +errorCallback :: TQueue Event -> GLFW.Error -> String -> IO () +windowPosCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +windowSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +windowCloseCallback :: TQueue Event -> GLFW.Window -> IO () +windowRefreshCallback :: TQueue Event -> GLFW.Window -> IO () +windowFocusCallback :: TQueue Event -> GLFW.Window -> GLFW.FocusState -> IO () +windowIconifyCallback :: TQueue Event -> GLFW.Window -> GLFW.IconifyState -> IO () +framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO () +mouseButtonCallback :: TQueue Event -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO () +cursorPosCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () +cursorEnterCallback :: TQueue Event -> GLFW.Window -> GLFW.CursorState -> IO () +scrollCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO () +keyCallback :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () +charCallback :: TQueue Event -> GLFW.Window -> Char -> IO () + +errorCallback tc e s = atomically $ writeTQueue tc $ EventError e s +windowPosCallback tc win x y = atomically $ writeTQueue tc $ EventWindowPos win x y +windowSizeCallback tc win w h = atomically $ writeTQueue tc $ EventWindowSize win w h +windowCloseCallback tc win = atomically $ writeTQueue tc $ EventWindowClose win +windowRefreshCallback tc win = atomically $ writeTQueue tc $ EventWindowRefresh win +windowFocusCallback tc win fa = atomically $ writeTQueue tc $ EventWindowFocus win fa +windowIconifyCallback tc win ia = atomically $ writeTQueue tc $ EventWindowIconify win ia +framebufferSizeCallback tc win w h = atomically $ writeTQueue tc $ EventFramebufferSize win w h +mouseButtonCallback tc win mb mba mk = atomically $ writeTQueue tc $ EventMouseButton win mb mba mk +cursorPosCallback tc win x y = atomically $ writeTQueue tc $ EventCursorPos win x y +cursorEnterCallback tc win ca = atomically $ writeTQueue tc $ EventCursorEnter win ca +scrollCallback tc win x y = atomically $ writeTQueue tc $ EventScroll win x y +keyCallback tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey win k sc ka mk +charCallback tc win c = atomically $ writeTQueue tc $ EventChar win c + +-------------------------------------------------------------------------------- + +runDemo :: Env -> State -> IO () +runDemo env state = do + printInstructions + void $ evalRWST (adjustWindow >> run) env state + +run :: Demo () +run = do + win <- asks envWindow + + draw + liftIO $ do + GLFW.swapBuffers win + GL.flush -- not necessary, but someone recommended it + GLFW.pollEvents + processEvents + + state <- get + if stateDragging state + then do + let sodx = stateDragStartX state + sody = stateDragStartY state + sodxa = stateDragStartXAngle state + sodya = stateDragStartYAngle state + (x, y) <- liftIO $ GLFW.getCursorPos win + let myrot = (x - sodx) / 2 + mxrot = (y - sody) / 2 + put $ state + { stateXAngle = sodxa + mxrot + , stateYAngle = sodya + myrot + } + else do + (kxrot, kyrot) <- liftIO $ getCursorKeyDirections win + (jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1 + put $ state + { stateXAngle = stateXAngle state + (2 * kxrot) + (2 * jxrot) + , stateYAngle = stateYAngle state + (2 * kyrot) + (2 * jyrot) + } + + mt <- liftIO GLFW.getTime + modify $ \s -> s + { stateGearZAngle = maybe 0 (realToFrac . (100*)) mt } - GLFW.setWindowSizeCallback windowSizeCallback + q <- liftIO $ GLFW.windowShouldClose win + unless q run - GL.clearColor GL.$= GL.Color4 0.05 0.05 0.05 1 - GL.depthFunc GL.$= Just GL.Less - GL.colorMaterial GL.$= Just (GL.FrontAndBack, GL.AmbientAndDiffuse) - GL.shadeModel GL.$= GL.Smooth +processEvents :: Demo () +processEvents = do + tc <- asks envEventsChan + me <- liftIO $ atomically $ tryReadTQueue tc + case me of + Just e -> do + processEvent e + processEvents + Nothing -> return () - GL.lighting GL.$= GL.Enabled - GL.lightModelAmbient GL.$= GL.Color4 0.2 0.2 0.2 1 - GL.position (GL.Light 0) GL.$= GL.Vertex4 (-10) 10 (-10) 0 - GL.ambient (GL.Light 0) GL.$= GL.Color4 0.4 0.4 0.4 1 - GL.diffuse (GL.Light 0) GL.$= GL.Color4 0.8 0.8 0.8 1 - GL.light (GL.Light 0) GL.$= GL.Enabled +processEvent :: Event -> Demo () +processEvent ev = + case ev of + (EventError e s) -> do + printEvent "error" [show e, show s] + win <- asks envWindow + liftIO $ GLFW.setWindowShouldClose win True -windowSizeCallback :: Int -> Int -> IO () -windowSizeCallback w h = do - GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h)) - GLU.gluPerspective 45 (fromIntegral w / fromIntegral h) 0.1 100 + (EventWindowPos _ x y) -> + printEvent "window pos" [show x, show y] -start :: IO () -start = - loop 0 0 + (EventWindowSize _ width height) -> do + printEvent "window size" [show width, show height] + modify $ \s -> s + { stateWindowWidth = width + , stateWindowHeight = height + } + adjustWindow + + (EventWindowClose _) -> + printEvent "window close" [] + + (EventWindowRefresh _) -> + printEvent "window refresh" [] + + (EventWindowFocus _ fs) -> + printEvent "window focus" [show fs] + + (EventWindowIconify _ is) -> + printEvent "window iconify" [show is] + + (EventFramebufferSize _ w h) -> + printEvent "framebuffer size" [show w, show h] + + (EventMouseButton _ mb mbs mk) -> do + printEvent "mouse button" [show mb, show mbs, showModifierKeys mk] + when (mb == GLFW.MouseButton'1) $ do + let pressed = mbs == GLFW.MouseButtonState'Pressed + modify $ \s -> s + { stateMouseDown = pressed + } + unless pressed $ + modify $ \s -> s + { stateDragging = False + } + + (EventCursorPos _ x y) -> do + let x' = round x :: Int + y' = round y :: Int + printEvent "cursor pos" [show x', show y'] + state <- get + when (stateMouseDown state && not (stateDragging state)) $ + put $ state + { stateDragging = True + , stateDragStartX = x + , stateDragStartY = y + , stateDragStartXAngle = stateXAngle state + , stateDragStartYAngle = stateYAngle state + } + + (EventCursorEnter _ cs) -> + printEvent "cursor enter" [show cs] + + (EventScroll _ x y) -> do + let x' = round x :: Int + y' = round y :: Int + printEvent "scroll" [show x', show y'] + env <- ask + modify $ \s -> s + { stateZDist = + let zDist' = stateZDist s + realToFrac (negate $ y / 2) + in curb (envZDistClosest env) (envZDistFarthest env) zDist' + } + adjustWindow + + (EventKey win k scancode ks mk) -> do + printEvent "key" [show k, show scancode, show ks, showModifierKeys mk] + when (ks == GLFW.KeyState'Pressed) $ do + -- Q, Esc: exit + when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $ + liftIO $ GLFW.setWindowShouldClose win True + -- ?: print instructions + when (k == GLFW.Key'Slash && GLFW.modifierKeysShift mk) $ + liftIO printInstructions + -- i: print GLFW information + when (k == GLFW.Key'I) $ + liftIO $ printInformation win + + (EventChar _ c) -> + printEvent "char" [show c] + +adjustWindow :: Demo () +adjustWindow = do + state <- get + let width = stateWindowWidth state + height = stateWindowHeight state + zDist = stateZDist state + + let pos = GL.Position 0 0 + size = GL.Size (fromIntegral width) (fromIntegral height) + h = fromIntegral height / fromIntegral width :: Double + znear = 1 :: Double + zfar = 40 :: Double + xmax = znear * 0.5 :: Double + liftIO $ do + GL.viewport GL.$= (pos, size) + GL.matrixMode GL.$= GL.Projection + GL.loadIdentity + GL.frustum (realToFrac $ -xmax) + (realToFrac xmax) + (realToFrac $ -xmax * realToFrac h) + (realToFrac $ xmax * realToFrac h) + (realToFrac znear) + (realToFrac zfar) + GL.matrixMode GL.$= GL.Modelview 0 + GL.loadIdentity + GL.translate (GL.Vector3 0 0 (negate $ realToFrac zDist) :: GL.Vector3 GL.GLfloat) + +draw :: Demo () +draw = do + env <- ask + state <- get + let gear1 = envGear1 env + gear2 = envGear2 env + gear3 = envGear3 env + xa = stateXAngle state + ya = stateYAngle state + za = stateZAngle state + ga = stateGearZAngle state + liftIO $ do + GL.clear [GL.ColorBuffer, GL.DepthBuffer] + GL.preservingMatrix $ do + GL.rotate (realToFrac xa) xunit + GL.rotate (realToFrac ya) yunit + GL.rotate (realToFrac za) zunit + GL.preservingMatrix $ do + GL.translate gear1vec + GL.rotate (realToFrac ga) zunit + GL.callList gear1 + GL.preservingMatrix $ do + GL.translate gear2vec + GL.rotate (-2 * realToFrac ga - 9) zunit + GL.callList gear2 + GL.preservingMatrix $ do + GL.translate gear3vec + GL.rotate (-2 * realToFrac ga - 25) zunit + GL.callList gear3 + where + gear1vec = GL.Vector3 (-3) (-2) 0 :: GL.Vector3 GL.GLfloat + gear2vec = GL.Vector3 3.1 (-2) 0 :: GL.Vector3 GL.GLfloat + gear3vec = GL.Vector3 (-3.1) 4.2 0 :: GL.Vector3 GL.GLfloat + xunit = GL.Vector3 1 0 0 :: GL.Vector3 GL.GLfloat + yunit = GL.Vector3 0 1 0 :: GL.Vector3 GL.GLfloat + zunit = GL.Vector3 0 0 1 :: GL.Vector3 GL.GLfloat + +getCursorKeyDirections :: GLFW.Window -> IO (Double, Double) +getCursorKeyDirections win = do + x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up + x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down + y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left + y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right + let x0n = if x0 then (-1) else 0 + x1n = if x1 then 1 else 0 + y0n = if y0 then (-1) else 0 + y1n = if y1 then 1 else 0 + return (x0n + x1n, y0n + y1n) + +getJoystickDirections :: GLFW.Joystick -> IO (Double, Double) +getJoystickDirections js = do + maxes <- GLFW.getJoystickAxes js + return $ case maxes of + (Just (x:y:_)) -> (-y, x) + _ -> ( 0, 0) + +isPress :: GLFW.KeyState -> Bool +isPress GLFW.KeyState'Pressed = True +isPress GLFW.KeyState'Repeating = True +isPress _ = False + +-------------------------------------------------------------------------------- + +printInstructions :: IO () +printInstructions = + putStrLn $ render $ + nest 4 ( + text "------------------------------------------------------------" $+$ + text "'?': Print these instructions" $+$ + text "'i': Print GLFW information" $+$ + text "" $+$ + text "* Mouse cursor, keyboard cursor keys, and/or joystick" $+$ + text " control rotation." $+$ + text "* Mouse scroll wheel controls distance from scene." $+$ + text "------------------------------------------------------------" + ) + +printInformation :: GLFW.Window -> IO () +printInformation win = do + version <- GLFW.getVersion + versionString <- GLFW.getVersionString + monitorInfos <- runMaybeT getMonitorInfos + joystickNames <- getJoystickNames + clientAPI <- GLFW.getWindowClientAPI win + cv0 <- GLFW.getWindowContextVersionMajor win + cv1 <- GLFW.getWindowContextVersionMinor win + cv2 <- GLFW.getWindowContextVersionRevision win + robustness <- GLFW.getWindowContextRobustness win + forwardCompat <- GLFW.getWindowOpenGLForwardCompat win + debug <- GLFW.getWindowOpenGLDebugContext win + profile <- GLFW.getWindowOpenGLProfile win + + putStrLn $ render $ + nest 4 ( + text "------------------------------------------------------------" $+$ + text "GLFW C library:" $+$ + nest 4 ( + text "Version:" <+> renderVersion version $+$ + text "Version string:" <+> renderVersionString versionString + ) $+$ + text "Monitors:" $+$ + nest 4 ( + renderMonitorInfos monitorInfos + ) $+$ + text "Joysticks:" $+$ + nest 4 ( + renderJoystickNames joystickNames + ) $+$ + text "OpenGL context:" $+$ + nest 4 ( + text "Client API:" <+> renderClientAPI clientAPI $+$ + text "Version:" <+> renderContextVersion cv0 cv1 cv2 $+$ + text "Robustness:" <+> renderContextRobustness robustness $+$ + text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$ + text "Debug:" <+> renderDebug debug $+$ + text "Profile:" <+> renderProfile profile + ) $+$ + text "------------------------------------------------------------" + ) where - loop xa ya = do - Display.draw xa ya - GLFW.resetTime + renderVersion (GLFW.Version v0 v1 v2) = + text $ intercalate "." $ map show [v0, v1, v2] - q0 <- GLFW.keyIsPressed GLFW.KeyEsc - q1 <- GLFW.keyIsPressed (GLFW.CharKey 'Q') - unless (q0 || q1) $ do - (jlr, jud) <- getJoystickDirections - (klr, kud) <- getCursorKeyDirections + renderVersionString = + text . show - let xa' = (xa + jud * maxAngle) - kud - let ya' = (ya + negate jlr * maxAngle) - klr + renderMonitorInfos = + maybe (text "(error)") (vcat . map renderMonitorInfo) - t <- liftM (numSecondsBetweenFrames -) GLFW.getTime - when (t > 0) (GLFW.sleep t) + renderMonitorInfo (name, (x,y), (w,h), vms) = + text (show name) $+$ + nest 4 ( + location <+> size $+$ + fsep (map renderVideoMode vms) + ) + where + location = int x <> text "," <> int y + size = int w <> text "x" <> int h <> text "mm" - loop xa' ya' + renderVideoMode (GLFW.VideoMode w h r g b rr) = + brackets $ res <+> rgb <+> hz where - maxAngle :: Float - maxAngle = 1 + res = int w <> text "x" <> int h + rgb = int r <> text "x" <> int g <> text "x" <> int b + hz = int rr <> text "Hz" - numSecondsBetweenFrames :: Double - numSecondsBetweenFrames = recip (fromIntegral framesPerSecond) + renderJoystickNames pairs = + vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs - framesPerSecond :: Int - framesPerSecond = 200 + renderContextVersion v0 v1 v2 = + hcat [int v0, text ".", int v1, text ".", int v2] -stop :: IO () -stop = do - GLFW.closeWindow - GLFW.terminate + renderClientAPI = text . show + renderContextRobustness = text . show + renderForwardCompat = text . show + renderDebug = text . show + renderProfile = text . show -getJoystickDirections :: IO (Float, Float) -getJoystickDirections = do - r <- take 2 `fmap` GLFW.getJoystickPosition GLFW.Joystick0 2 - return $ - case r of - [x, y] -> (x, y) - _ -> (0, 0) +type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode]) -getCursorKeyDirections :: IO (Float, Float) -getCursorKeyDirections = do - l <- toFloat `fmap` GLFW.keyIsPressed GLFW.KeyLeft - r <- toFloat `fmap` GLFW.keyIsPressed GLFW.KeyRight - u <- toFloat `fmap` GLFW.keyIsPressed GLFW.KeyUp - d <- toFloat `fmap` GLFW.keyIsPressed GLFW.KeyDown - return (-l + r, -u + d) +getMonitorInfos :: MaybeT IO [MonitorInfo] +getMonitorInfos = + getMonitors >>= mapM getMonitorInfo where - toFloat b = if b then 1 else 0 + getMonitors :: MaybeT IO [GLFW.Monitor] + getMonitors = MaybeT GLFW.getMonitors + + getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo + getMonitorInfo mon = do + name <- getMonitorName mon + vms <- getVideoModes mon + MaybeT $ do + pos <- liftIO $ GLFW.getMonitorPos mon + size <- liftIO $ GLFW.getMonitorPhysicalSize mon + return $ Just (name, pos, size, vms) + + getMonitorName :: GLFW.Monitor -> MaybeT IO String + getMonitorName mon = MaybeT $ GLFW.getMonitorName mon + + getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode] + getVideoModes mon = MaybeT $ GLFW.getVideoModes mon + +getJoystickNames :: IO [(GLFW.Joystick, String)] +getJoystickNames = + catMaybes `fmap` mapM getJoystick joysticks + where + getJoystick js = + fmap (maybe Nothing (\name -> Just (js, name))) + (GLFW.getJoystickName js) + +-------------------------------------------------------------------------------- + +printEvent :: String -> [String] -> Demo () +printEvent cbname fields = + liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields + +showModifierKeys :: GLFW.ModifierKeys -> String +showModifierKeys mk = + "[mod keys: " ++ keys ++ "]" + where + keys = if null xs then "none" else unwords xs + xs = catMaybes ys + ys = [ if GLFW.modifierKeysShift mk then Just "shift" else Nothing + , if GLFW.modifierKeysControl mk then Just "control" else Nothing + , if GLFW.modifierKeysAlt mk then Just "alt" else Nothing + , if GLFW.modifierKeysSuper mk then Just "super" else Nothing + ] + +curb :: Ord a => a -> a -> a -> a +curb l h x + | x < l = l + | x > h = h + | otherwise = x + +-------------------------------------------------------------------------------- + +joysticks :: [GLFW.Joystick] +joysticks = + [ GLFW.Joystick'1 + , GLFW.Joystick'2 + , GLFW.Joystick'3 + , GLFW.Joystick'4 + , GLFW.Joystick'5 + , GLFW.Joystick'6 + , GLFW.Joystick'7 + , GLFW.Joystick'8 + , GLFW.Joystick'9 + , GLFW.Joystick'10 + , GLFW.Joystick'11 + , GLFW.Joystick'12 + , GLFW.Joystick'13 + , GLFW.Joystick'14 + , GLFW.Joystick'15 + , GLFW.Joystick'16 + ]