GLFW-b-demo 0.1.1 → 1.0.0
raw patch · 7 files changed
+630/−187 lines, 7 filesdep +mtldep +prettydep +stmdep −GLURawdep ~GLFW-bdep ~OpenGLdep ~base
Dependencies added: mtl, pretty, stm, transformers
Dependencies removed: GLURaw
Dependency ranges changed: GLFW-b, OpenGL, base
Files
- GLFW-b-demo.cabal +31/−28
- LICENSE +1/−1
- README.md +7/−0
- TODO +13/−0
- src/Cube.hs +0/−62
- src/Display.hs +0/−24
- src/Main.hs +578/−72
GLFW-b-demo.cabal view
@@ -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 <brian@lorf.org>-maintainer: Brian Lewis <brian@lorf.org>+author: Brian Lewis <brian@lorf.org>+maintainer: Brian Lewis <brian@lorf.org> -license: BSD3-license-file: LICENSE+category: Graphics+synopsis: GLFW-b demo+description:+ This is a demonstration of <http://hackage.haskell.org/package/GLFW-b GLFW-b>+ allowing the user to interact with colorful spinning gears using cursor keys,+ mouse, scroll wheel, and joystick.+ .+ Here's a <http://i.imgur.com/JZKwVSu.png screenshot>. --- -- -- -- -- -- -- -- -- --+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
LICENSE view
@@ -1,4 +1,4 @@-Copyright Brian Lewis <brian@lorf.org> 2010+Copyright Brian Lewis <brian@lorf.org> 2013 All rights reserved.
+ README.md view
@@ -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
+ TODO view
@@ -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.
− src/Cube.hs
@@ -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
− src/Display.hs
@@ -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
src/Main.hs view
@@ -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+ ]