403 lines
18 KiB
Haskell
403 lines
18 KiB
Haskell
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
|
|
module Main where
|
|
|
|
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
|
|
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
|
|
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
|
|
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)
|
|
|
|
-- Monad-foo and higher functional stuff
|
|
import Control.Monad (unless, when, join)
|
|
import Control.Arrow ((***))
|
|
|
|
-- data consistency/conversion
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.STM (TQueue,
|
|
newTQueueIO)
|
|
|
|
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
|
|
import Data.Functor ((<$>))
|
|
import Data.Monoid (mappend)
|
|
|
|
-- FFI
|
|
import Foreign.Marshal.Array (pokeArray)
|
|
import Foreign.Marshal.Alloc (allocaBytes)
|
|
|
|
-- Math
|
|
import Control.Lens ((^.), (.~), (%~))
|
|
|
|
-- GUI
|
|
import Graphics.UI.SDL as SDL
|
|
|
|
-- Render
|
|
import qualified Graphics.Rendering.OpenGL.GL as GL
|
|
import Graphics.Rendering.OpenGL.Raw.Core31
|
|
import Data.Time (getCurrentTime, diffUTCTime)
|
|
|
|
-- Our modules
|
|
import Render.Misc (checkError, createFrustum, curb,
|
|
genColorData)
|
|
import Render.Render (initRendering,
|
|
initMapShader,
|
|
initHud, render)
|
|
import Render.Types
|
|
import UI.Callbacks
|
|
import Map.Graphics
|
|
import Types
|
|
import Importer.IQM.Parser
|
|
--import Data.Attoparsec.Char8 (parseTest)
|
|
--import qualified Data.ByteString as B
|
|
|
|
-- import qualified Debug.Trace as D (trace)
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
testParser :: String -> IO ()
|
|
testParser a = putStrLn . show =<< parseIQM a
|
|
{-do
|
|
f <- B.readFile a
|
|
putStrLn "reading in:"
|
|
putStrLn $ show f
|
|
putStrLn "parsed:"
|
|
parseTest parseIQM f-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
|
|
main :: IO ()
|
|
main =
|
|
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute!
|
|
SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
|
|
,WindowShown -- window should be visible
|
|
,WindowResizable -- and resizable
|
|
,WindowInputFocus -- focused (=> active)
|
|
,WindowMouseFocus -- Mouse into it
|
|
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
|
|
] $ \window' -> do
|
|
withOpenGL window' $ do
|
|
|
|
--Create Renderbuffer & Framebuffer
|
|
-- We will render to this buffer to copy the result into textures
|
|
renderBuffer <- GL.genObjectName
|
|
frameBuffer <- GL.genObjectName
|
|
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
|
|
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
|
|
|
(Size fbWidth fbHeight) <- glGetDrawableSize window'
|
|
initRendering
|
|
--generate map vertices
|
|
glMap' <- initMapShader 4 =<< getMapBufferObject
|
|
print window'
|
|
eventQueue <- newTQueueIO :: IO (TQueue Event)
|
|
putStrLn "foo"
|
|
now <- getCurrentTime
|
|
putStrLn "foo"
|
|
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
|
|
--TTF.setFontStyle font TTFNormal
|
|
--TTF.setFontHinting font TTFHNormal
|
|
|
|
glHud' <- initHud
|
|
let zDistClosest' = 1
|
|
zDistFarthest' = zDistClosest' + 50
|
|
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
|
fov = 90 --field of view
|
|
near = 1 --near plane
|
|
far = 500 --far plane
|
|
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
|
frust = createFrustum fov near far ratio
|
|
(guiMap, guiRoots) = createGUI
|
|
aks = ArrowKeyState {
|
|
_up = False
|
|
, _down = False
|
|
, _left = False
|
|
, _right = False
|
|
}
|
|
env = Env
|
|
{ _eventsChan = eventQueue
|
|
, _windowObject = window'
|
|
, _zDistClosest = zDistClosest'
|
|
, _zDistFarthest = zDistFarthest'
|
|
}
|
|
state = State
|
|
{ _window = WindowState
|
|
{ _width = fbWidth
|
|
, _height = fbHeight
|
|
, _shouldClose = False
|
|
}
|
|
, _camera = CameraState
|
|
{ _xAngle = pi/6
|
|
, _yAngle = pi/2
|
|
, _zDist = 10
|
|
, _frustum = frust
|
|
, _camObject = createFlatCam 25 25
|
|
}
|
|
, _io = IOState
|
|
{ _clock = now
|
|
}
|
|
, _mouse = MouseState
|
|
{ _isDown = False
|
|
, _isDragging = False
|
|
, _dragStartX = 0
|
|
, _dragStartY = 0
|
|
, _dragStartXAngle = 0
|
|
, _dragStartYAngle = 0
|
|
, _mousePosition = Types.Position
|
|
{ Types.__x = 5
|
|
, Types.__y = 5
|
|
}
|
|
}
|
|
, _keyboard = KeyboardState
|
|
{ _arrowsPressed = aks
|
|
}
|
|
, _gl = GLState
|
|
{ _glMap = glMap'
|
|
, _glHud = glHud'
|
|
, _glRenderbuffer = renderBuffer
|
|
, _glFramebuffer = frameBuffer
|
|
}
|
|
, _game = GameState
|
|
{
|
|
}
|
|
, _ui = UIState
|
|
{ _uiHasChanged = True
|
|
, _uiMap = guiMap
|
|
, _uiRoots = guiRoots
|
|
}
|
|
}
|
|
|
|
putStrLn "init done."
|
|
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
|
|
putStrLn "shutdown complete."
|
|
|
|
--SDL.glDeleteContext mainGlContext
|
|
--SDL.destroyRenderer renderer
|
|
--destroyWindow window
|
|
|
|
-- Main game loop
|
|
|
|
run :: Pioneers ()
|
|
run = do
|
|
env <- ask
|
|
|
|
-- draw Scene
|
|
draw
|
|
liftIO $ glSwapWindow (env ^. windowObject)
|
|
-- getEvents & process
|
|
processEvents
|
|
|
|
-- update State
|
|
|
|
state <- get
|
|
-- change in camera-angle
|
|
when (state ^. mouse.isDragging) $ do
|
|
let sodx = state ^. mouse.dragStartX
|
|
sody = state ^. mouse.dragStartY
|
|
sodxa = state ^. mouse.dragStartXAngle
|
|
sodya = state ^. mouse.dragStartYAngle
|
|
x' = state ^. mouse.mousePosition._x
|
|
y' = state ^. mouse.mousePosition._y
|
|
myrot = (x' - sodx) / 2
|
|
mxrot = (y' - sody) / 2
|
|
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
|
|
newXAngle' = sodxa + mxrot/100
|
|
newYAngle
|
|
| newYAngle' > pi = newYAngle' - 2 * pi
|
|
| newYAngle' < (-pi) = newYAngle' + 2 * pi
|
|
| otherwise = newYAngle'
|
|
newYAngle' = sodya + myrot/100
|
|
|
|
modify $ ((camera.xAngle) .~ newXAngle)
|
|
. ((camera.yAngle) .~ newYAngle)
|
|
|
|
-- get cursor-keys - if pressed
|
|
--TODO: Add sin/cos from stateYAngle
|
|
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
|
|
let
|
|
multc = cos $ state ^. camera.yAngle
|
|
mults = sin $ state ^. camera.yAngle
|
|
modx x' = x' - 0.2 * kxrot * multc
|
|
- 0.2 * kyrot * mults
|
|
mody y' = y' + 0.2 * kxrot * mults
|
|
- 0.2 * kyrot * multc
|
|
modify $ camera.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)))
|
|
|
|
{-
|
|
--modify the state with all that happened in mt time.
|
|
mt <- liftIO GLFW.getTime
|
|
modify $ \s -> s
|
|
{
|
|
}
|
|
-}
|
|
|
|
mt <- liftIO $ do
|
|
let double = fromRational.toRational :: (Real a) => a -> Double
|
|
now <- getCurrentTime
|
|
diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
|
|
title <- return $ unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
|
|
setWindowTitle (env ^. windowObject) title
|
|
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
|
|
threadDelay sleepAmount
|
|
return now
|
|
-- set state with new clock-time
|
|
modify $ io.clock .~ mt
|
|
shouldClose' <- return $ state ^. window.shouldClose
|
|
unless shouldClose' run
|
|
|
|
draw :: Pioneers ()
|
|
draw = do
|
|
state <- get
|
|
when (state ^. ui . uiHasChanged) prepareGUI
|
|
render
|
|
|
|
getArrowMovement :: Pioneers (Int, Int)
|
|
getArrowMovement = do
|
|
state <- get
|
|
aks <- return $ state ^. (keyboard.arrowsPressed)
|
|
let
|
|
horz = left' + right'
|
|
vert = up'+down'
|
|
left' = if aks ^. left then -1 else 0
|
|
right' = if aks ^. right then 1 else 0
|
|
up' = if aks ^. up then -1 else 0
|
|
down' = if aks ^. down then 1 else 0
|
|
return (horz,vert)
|
|
|
|
adjustWindow :: Pioneers ()
|
|
adjustWindow = do
|
|
state <- get
|
|
let fbWidth = state ^. window.width
|
|
fbHeight = state ^. window.height
|
|
fov = 90 --field of view
|
|
near = 1 --near plane
|
|
far = 100 --far plane
|
|
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
|
frust = createFrustum fov near far ratio
|
|
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
|
|
modify $ camera.frustum .~ frust
|
|
rb <- liftIO $ do
|
|
-- bind ints to CInt for lateron.
|
|
let fbCWidth = (fromInteger.toInteger) fbWidth
|
|
fbCHeight = (fromInteger.toInteger) fbHeight
|
|
-- free old renderbuffer & create new (reuse is NOT advised!)
|
|
GL.deleteObjectName (state ^. gl.glRenderbuffer)
|
|
renderBuffer <- GL.genObjectName
|
|
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
|
GL.renderbufferStorage
|
|
GL.Renderbuffer -- use the only available renderbuffer
|
|
-- - must be this constant.
|
|
GL.DepthComponent' -- 32-bit float-rgba-color
|
|
(GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer
|
|
|
|
|
|
let hudtexid = state ^. gl.glHud.hudTexture
|
|
maptexid = state ^. gl.glMap.renderedMapTexture
|
|
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
|
|
--default to ugly pink to see if
|
|
--somethings go wrong.
|
|
let imData = genColorData (fbWidth*fbHeight) [255,0,255,0]
|
|
--putStrLn $ show imData
|
|
pokeArray ptr imData
|
|
-- HUD
|
|
textureBinding Texture2D GL.$= Just hudtexid
|
|
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
|
|
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
|
|
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
|
|
-- MAP
|
|
textureBinding Texture2D GL.$= Just maptexid
|
|
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
|
|
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
|
|
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
|
|
checkError "setting up HUD-Tex"
|
|
return renderBuffer
|
|
modify $ gl.glRenderbuffer .~ rb
|
|
modify $ ui.uiHasChanged .~ True
|
|
|
|
processEvents :: Pioneers ()
|
|
processEvents = do
|
|
me <- liftIO pollEvent
|
|
case me of
|
|
Just e -> do
|
|
processEvent e
|
|
processEvents
|
|
Nothing -> return ()
|
|
|
|
processEvent :: Event -> Pioneers ()
|
|
processEvent e = do
|
|
env <- ask
|
|
case eventData e of
|
|
Window _ winEvent ->
|
|
case winEvent of
|
|
Closing ->
|
|
modify $ window.shouldClose .~ True
|
|
Resized {windowResizedTo=size} -> do
|
|
modify $ (window . width .~ sizeWidth size)
|
|
. (window . height .~ sizeHeight size)
|
|
adjustWindow
|
|
SizeChanged ->
|
|
adjustWindow
|
|
_ ->
|
|
return ()
|
|
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
|
|
Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey
|
|
-- need modifiers? use "keyModifiers key" to get them
|
|
let aks = keyboard.arrowsPressed in
|
|
case keyScancode key of
|
|
SDL.R ->
|
|
liftIO $ do
|
|
r <- getRenderer $ env ^. windowObject
|
|
putStrLn $ unwords ["Renderer: ",show r]
|
|
Escape ->
|
|
modify $ window.shouldClose .~ True
|
|
SDL.Left ->
|
|
modify $ aks.left .~ (movement == KeyDown)
|
|
SDL.Right ->
|
|
modify $ aks.right .~ (movement == KeyDown)
|
|
SDL.Up ->
|
|
modify $ aks.up .~ (movement == KeyDown)
|
|
SDL.Down ->
|
|
modify $ aks.down .~ (movement == KeyDown)
|
|
SDL.KeypadPlus ->
|
|
when (movement == KeyDown) $ do
|
|
modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
|
|
state <- get
|
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
|
SDL.KeypadMinus ->
|
|
when (movement == KeyDown) $ do
|
|
modify $ (gl.glMap.stateTessellationFactor) %~ ((max 1) . (+(-1)))
|
|
state <- get
|
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
|
_ ->
|
|
return ()
|
|
MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do
|
|
state <- get
|
|
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
|
modify $ (mouse.isDragging .~ True)
|
|
. (mouse.dragStartX .~ (fromIntegral x))
|
|
. (mouse.dragStartY .~ (fromIntegral y))
|
|
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
|
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
|
|
|
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
|
|
. (mouse.mousePosition. Types._y .~ (fromIntegral y))
|
|
MouseButton _ _{-mouseId-} button state (SDL.Position x y) ->
|
|
case button of
|
|
LeftButton -> do
|
|
let pressed = state == Pressed
|
|
modify $ mouse.isDown .~ pressed
|
|
unless pressed $ do
|
|
st <- get
|
|
if st ^. mouse.isDragging then
|
|
modify $ mouse.isDragging .~ False
|
|
else
|
|
clickHandler (UI.Callbacks.Pixel x y)
|
|
RightButton -> do
|
|
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
|
|
_ ->
|
|
return ()
|
|
MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
|
|
state <- get
|
|
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
|
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
|
|
Quit -> modify $ window.shouldClose .~ True
|
|
-- there is more (joystic, touchInterface, ...), but currently ignored
|
|
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
|