661 lines
25 KiB
Haskell
661 lines
25 KiB
Haskell
module Main (main) where
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
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 Control.Applicative
|
|
import Control.Lens
|
|
import Control.Monad (forever)
|
|
import Data.Distributive (distribute)
|
|
import Foreign (Ptr, castPtr, nullPtr, sizeOf, with)
|
|
import Foreign.C (CFloat)
|
|
|
|
import Graphics.Rendering.OpenGL (($=))
|
|
import qualified Graphics.Rendering.OpenGL as GL
|
|
import qualified Graphics.Rendering.OpenGL.Raw as GL
|
|
import qualified Graphics.UI.GLFW as GLFW
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
import qualified Data.Vector.Storable as V
|
|
import Linear as L
|
|
import Linear ((!*!))
|
|
|
|
import Data.IORef
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
--------------------------------------------------------------------------------
|
|
triangleTransformation :: (Epsilon a, Floating a) => a -> M44 a
|
|
triangleTransformation =
|
|
liftA2 (!*!) triangleTranslation triangleRotation
|
|
|
|
--------------------------------------------------------------------------------
|
|
triangleRotation :: (Epsilon a, Floating a) => a -> M44 a
|
|
triangleRotation t =
|
|
m33_to_m44 $
|
|
fromQuaternion $
|
|
axisAngle (V3 0 1 0) (t * 2)
|
|
|
|
triangleTranslation :: Floating a => a -> M44 a
|
|
triangleTranslation t =
|
|
eye4 & translation .~ V3 (sin t * 2) 0 (-5)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let width = 640
|
|
height = 480
|
|
|
|
eventsChan <- newTQueueIO :: IO (TQueue Event)
|
|
|
|
withWindow width height "GLFW-b-demo" $ \win -> do
|
|
let z = 0
|
|
let vertices = V.fromList [ 0, 1, 0
|
|
, -1, -1, z
|
|
, 1, -1, z ] :: V.Vector Float
|
|
vertexAttribute = GL.AttribLocation 0
|
|
|
|
cubeVbo <- GL.genObjectName
|
|
|
|
GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
|
|
|
|
V.unsafeWith vertices $ \v -> GL.bufferData GL.ArrayBuffer $=
|
|
(fromIntegral $ V.length vertices * sizeOf (0 :: Float), v, GL.StaticDraw)
|
|
|
|
GL.vertexAttribPointer vertexAttribute $=
|
|
(GL.ToFloat, GL.VertexArrayDescriptor 3 GL.Float 0 nullPtr)
|
|
|
|
GL.vertexAttribArray vertexAttribute $= GL.Enabled
|
|
GL.bindBuffer GL.ArrayBuffer $= Just cubeVbo
|
|
|
|
vertexShader <- GL.createShader GL.VertexShader
|
|
fragmentShader <- GL.createShader GL.FragmentShader
|
|
|
|
GL.shaderSourceBS vertexShader $= Text.encodeUtf8
|
|
(Text.pack $ unlines
|
|
[ "#version 130"
|
|
, "uniform mat4 projection;"
|
|
, "uniform mat4 model;"
|
|
, "in vec3 in_Position;"
|
|
, "void main(void) {"
|
|
, " gl_Position = projection * model * vec4(in_Position, 1.0);"
|
|
, "}"
|
|
])
|
|
|
|
GL.shaderSourceBS fragmentShader $= Text.encodeUtf8
|
|
(Text.pack $ unlines
|
|
[ "#version 130"
|
|
, "out vec4 fragColor;"
|
|
, "void main(void) {"
|
|
, " fragColor = vec4(1.0,1.0,1.0,1.0);"
|
|
, "}"
|
|
])
|
|
|
|
GL.compileShader vertexShader
|
|
GL.compileShader fragmentShader
|
|
|
|
shaderProg <- GL.createProgram
|
|
GL.attachShader shaderProg vertexShader
|
|
GL.attachShader shaderProg fragmentShader
|
|
GL.attribLocation shaderProg "in_Position" $= vertexAttribute
|
|
GL.linkProgram shaderProg
|
|
GL.currentProgram $= Just shaderProg
|
|
|
|
let fov = 90
|
|
s = recip (tan $ fov * 0.5 * pi / 180)
|
|
f = 1000
|
|
n = 1
|
|
|
|
let perspective = V.fromList [ s, 0, 0, 0
|
|
, 0, s, 0, 0
|
|
, 0, 0, -(f/(f - n)), -1
|
|
, 0, 0, -((f*n)/(f-n)), 0
|
|
]
|
|
|
|
GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "projection")
|
|
V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv loc 1 0 ptr
|
|
|
|
tr <- newIORef 0
|
|
forever $ do
|
|
t <- readIORef tr
|
|
|
|
GL.clearColor $= GL.Color4 0.5 0.2 1 1
|
|
GL.clear [GL.ColorBuffer]
|
|
|
|
GL.UniformLocation loc <- GL.get (GL.uniformLocation shaderProg "model")
|
|
with (distribute $ triangleTransformation t) $ \ptr ->
|
|
GL.glUniformMatrix4fv loc 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
|
|
|
GL.drawArrays GL.Triangles 0 3
|
|
|
|
GLFW.swapBuffers win
|
|
writeIORef tr (t + 0.1)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
-- 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
|
|
}
|
|
|
|
q <- liftIO $ GLFW.windowShouldClose win
|
|
unless q run
|
|
|
|
processEvents :: Demo ()
|
|
processEvents = do
|
|
tc <- asks envEventsChan
|
|
me <- liftIO $ atomically $ tryReadTQueue tc
|
|
case me of
|
|
Just e -> do
|
|
processEvent e
|
|
processEvents
|
|
Nothing -> return ()
|
|
|
|
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
|
|
|
|
(EventWindowPos _ x y) ->
|
|
printEvent "window pos" [show x, show y]
|
|
|
|
(EventWindowSize _ width height) ->
|
|
printEvent "window size" [show width, show height]
|
|
|
|
(EventWindowClose _) ->
|
|
printEvent "window close" []
|
|
|
|
(EventWindowRefresh _) ->
|
|
printEvent "window refresh" []
|
|
|
|
(EventWindowFocus _ fs) ->
|
|
printEvent "window focus" [show fs]
|
|
|
|
(EventWindowIconify _ is) ->
|
|
printEvent "window iconify" [show is]
|
|
|
|
(EventFramebufferSize _ width height) -> do
|
|
printEvent "framebuffer size" [show width, show height]
|
|
modify $ \s -> s
|
|
{ stateWindowWidth = width
|
|
, stateWindowHeight = height
|
|
}
|
|
adjustWindow
|
|
|
|
(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
|
|
renderVersion (GLFW.Version v0 v1 v2) =
|
|
text $ intercalate "." $ map show [v0, v1, v2]
|
|
|
|
renderVersionString =
|
|
text . show
|
|
|
|
renderMonitorInfos =
|
|
maybe (text "(error)") (vcat . map renderMonitorInfo)
|
|
|
|
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"
|
|
|
|
renderVideoMode (GLFW.VideoMode w h r g b rr) =
|
|
brackets $ res <+> rgb <+> hz
|
|
where
|
|
res = int w <> text "x" <> int h
|
|
rgb = int r <> text "x" <> int g <> text "x" <> int b
|
|
hz = int rr <> text "Hz"
|
|
|
|
renderJoystickNames pairs =
|
|
vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs
|
|
|
|
renderContextVersion v0 v1 v2 =
|
|
hcat [int v0, text ".", int v1, text ".", int v2]
|
|
|
|
renderClientAPI = text . show
|
|
renderContextRobustness = text . show
|
|
renderForwardCompat = text . show
|
|
renderDebug = text . show
|
|
renderProfile = text . show
|
|
|
|
type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode])
|
|
|
|
getMonitorInfos :: MaybeT IO [MonitorInfo]
|
|
getMonitorInfos =
|
|
getMonitors >>= mapM getMonitorInfo
|
|
where
|
|
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
|
|
]
|
|
|