pioneers/src/Main.hs

620 lines
24 KiB
Haskell
Raw Normal View History

module Main (main) where
--------------------------------------------------------------------------------
2014-01-04 16:55:59 +01:00
import Control.Applicative
import Control.Concurrent.STM (TQueue, atomically, newTQueueIO, tryReadTQueue, writeTQueue)
2014-01-04 16:55:59 +01:00
import Control.Lens
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
2014-01-04 16:55:59 +01:00
import Data.Distributive (distribute)
import Foreign (Ptr, castPtr, nullPtr, sizeOf, with)
import Foreign.C (CFloat)
import Linear as L
import Linear ((!*!))
2014-01-03 23:19:39 +01:00
import qualified Graphics.Rendering.OpenGL.GL as GL
2014-01-04 03:10:06 +01:00
import qualified Graphics.Rendering.OpenGL.Raw as GL
2014-01-03 23:19:39 +01:00
import qualified Graphics.UI.GLFW as GLFW
2014-01-04 03:10:06 +01:00
import qualified Data.Vector.Storable as V
import Map.Map
import Render.Render (initShader)
2014-01-04 16:55:59 +01:00
import Render.Misc (up, lookAtUniformMatrix4fv, createFrustum, checkError)
--------------------------------------------------------------------------------
--Static Read-Only-State
data Env = Env
{ envEventsChan :: TQueue Event
, envWindow :: !GLFW.Window
, envZDistClosest :: !Double
, envZDistFarthest :: !Double
}
--Mutable State
data State = State
{ stateWindowWidth :: !Int
, stateWindowHeight :: !Int
, stateXAngle :: !Double
, stateYAngle :: !Double
, stateZAngle :: !Double
, stateZDist :: !Double
, stateMouseDown :: !Bool
, stateDragging :: !Bool
, stateDragStartX :: !Double
, stateDragStartY :: !Double
, stateDragStartXAngle :: !Double
, stateDragStartYAngle :: !Double
, stateFrustum :: [GL.GLfloat]
-- pointer to bindings for locations inside the compiled shader
-- mutable because shaders may be changed in the future.
, shdrVertexIndex :: !GL.AttribLocation
2014-01-04 14:09:42 +01:00
, shdrColorIndex :: !GL.AttribLocation
2014-01-04 16:55:59 +01:00
, shdrNormalIndex :: !GL.AttribLocation
, shdrProjMatIndex :: !GL.UniformLocation
2014-01-04 14:09:42 +01:00
, shdrModelMatIndex :: !GL.UniformLocation
-- the map
, stateMap :: !GL.BufferObject
, mapVert :: !GL.NumArrayIndices
}
type Pioneer = 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
--------------------------------------------------------------------------------
2013-12-22 23:29:11 +01:00
main :: IO ()
main = do
let width = 640
height = 480
eventsChan <- newTQueueIO :: IO (TQueue Event)
withWindow width height "Pioneers" $ \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
(fbWidth, fbHeight) <- GLFW.getFramebufferSize win
--generate map vertices
(mapBuffer, vert) <- getMapBufferObject
2014-01-04 16:55:59 +01:00
(ci, ni, vi, pi, mi) <- initShader
let zDistClosest = 10
zDistFarthest = zDistClosest + 20
fov = 90 --field of view
near = 1 --near plane
far = 100 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
env = Env
{ envEventsChan = eventsChan
, envWindow = win
, envZDistClosest = zDistClosest
, envZDistFarthest = zDistFarthest
}
state = State
{ stateWindowWidth = fbWidth
, stateWindowHeight = fbHeight
, stateXAngle = 0
, stateYAngle = 0
, stateZAngle = 0
, stateZDist = 10
, stateMouseDown = False
, stateDragging = False
, stateDragStartX = 0
, stateDragStartY = 0
, stateDragStartXAngle = 0
, stateDragStartYAngle = 0
, shdrVertexIndex = vi
2014-01-04 16:55:59 +01:00
, shdrNormalIndex = ni
2014-01-04 14:09:42 +01:00
, shdrColorIndex = ci
, shdrProjMatIndex = pi
2014-01-04 14:09:42 +01:00
, shdrModelMatIndex = mi
, stateMap = mapBuffer
, mapVert = vert
, stateFrustum = frust
}
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 ()
2014-01-04 16:55:59 +01:00
runDemo env state = void $ evalRWST (adjustWindow >> run) env state
run :: Pioneer ()
run = do
win <- asks envWindow
-- draw Scene
draw
liftIO $ do
GLFW.swapBuffers win
GLFW.pollEvents
-- getEvents & process
processEvents
-- update State
2014-01-04 14:09:42 +01:00
{-
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)
}
2014-01-04 14:09:42 +01:00
-}
{-
--modify the state with all that happened in mt time.
mt <- liftIO GLFW.getTime
modify $ \s -> s
{
}
-}
q <- liftIO $ GLFW.windowShouldClose win
unless q run
processEvents :: Pioneer ()
processEvents = do
tc <- asks envEventsChan
me <- liftIO $ atomically $ tryReadTQueue tc
case me of
Just e -> do
processEvent e
processEvents
Nothing -> return ()
processEvent :: Event -> Pioneer ()
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
-- i: print GLFW information
when (k == GLFW.Key'I) $
liftIO $ printInformation win
(EventChar _ c) ->
printEvent "char" [show c]
adjustWindow :: Pioneer ()
adjustWindow = do
state <- get
2014-01-03 23:19:39 +01:00
let fbWidth = stateWindowWidth state
fbHeight = stateWindowHeight state
fov = 90 --field of view
near = 1 --near plane
far = 100 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
put $ state {
stateFrustum = frust
}
draw :: Pioneer ()
draw = do
env <- ask
state <- get
let xa = stateXAngle state
ya = stateYAngle state
za = stateZAngle state
2014-01-04 14:09:42 +01:00
(GL.UniformLocation proj) = shdrProjMatIndex state
(GL.UniformLocation mmat) = shdrModelMatIndex state
vi = shdrVertexIndex state
2014-01-04 16:55:59 +01:00
ni = shdrNormalIndex state
2014-01-04 14:09:42 +01:00
ci = shdrColorIndex state
numVert = mapVert state
map' = stateMap state
frust = stateFrustum state
liftIO $ do
2014-01-04 14:09:42 +01:00
--(vi,GL.UniformLocation proj) <- initShader
GL.clearColor GL.$= GL.Color4 0.5 0.1 1 1
2014-01-04 16:55:59 +01:00
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
2014-01-04 03:10:06 +01:00
let fov = 90
s = recip (tan $ fov * 0.5 * pi / 180)
f = 1000
n = 1
2014-01-04 16:55:59 +01:00
let perspective = V4 (V4 s 0 0 0)
(V4 0 s 0 0)
(V4 0 0 (-(f/(f - n))) (-1))
(V4 0 0 (-((f*n)/(f-n))) 1)
!*!
V4 (V4 1 0 0 0)
(V4 0 0 1 0)
(V4 0 1 0 0)
(V4 0 0 0 1)
with (distribute $ perspective) $ \ptr ->
GL.glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
--V.unsafeWith perspective $ \ptr -> GL.glUniformMatrix4fv proj 1 0 ptr
let cam = crot !*! ctrans
ctrans = (eye4 & translation .~ V3 (-5) (-10) (-10)) :: M44 CFloat
crot = (m33_to_m44 $
(fromQuaternion $
axisAngle (V3 1 0 0) (pi/4))
!*!
(fromQuaternion $
axisAngle (V3 0 1 0) (pi/16))
) :: M44 CFloat
--V.unsafeWith model $ \ptr -> GL.glUniformMatrix4fv mmat 1 0 ptr
with (distribute $ cam) $ \ptr ->
GL.glUniformMatrix4fv mmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
2014-01-04 14:09:42 +01:00
GL.vertexAttribPointer ci GL.$= fgColorIndex
2014-01-04 16:55:59 +01:00
GL.vertexAttribPointer ni GL.$= fgNormalIndex
GL.vertexAttribPointer vi GL.$= fgVertexIndex
2014-01-03 22:31:01 +01:00
GL.drawArrays GL.Triangles 0 numVert
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
--------------------------------------------------------------------------------
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] -> Pioneer ()
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
]