removed testfile
This commit is contained in:
Stefan Dresselhaus
660
test2.hs
660
test2.hs
@@ -1,660 +0,0 @@
|
||||
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
|
||||
]
|
||||
|
||||
Reference in New Issue
Block a user