Merge branch 'tessallation' into mapmerge
Conflicts: src/Main.hs src/Map/Graphics.hs
This commit is contained in:
Stefan Dresselhaus
469
src/Main.hs
469
src/Main.hs
@ -1,19 +1,15 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
|
||||
module Main where
|
||||
|
||||
-- Monad-foo and higher functional stuff
|
||||
import Control.Applicative
|
||||
import Control.Monad (unless, void, when, join)
|
||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
||||
import Control.Arrow ((***))
|
||||
|
||||
-- data consistency/conversion
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.STM (TQueue, atomically,
|
||||
newTQueueIO,
|
||||
tryReadTQueue,
|
||||
writeTQueue, isEmptyTQueue,
|
||||
STM)
|
||||
import Control.Concurrent.STM (TQueue,
|
||||
newTQueueIO)
|
||||
|
||||
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
||||
evalRWST, get, liftIO,
|
||||
modify, put)
|
||||
@ -24,152 +20,135 @@ import Foreign (Ptr, castPtr, with)
|
||||
import Foreign.C (CFloat)
|
||||
|
||||
-- Math
|
||||
import Control.Lens (transposeOf, (^.))
|
||||
import Control.Lens ((^.), (.~), (%~))
|
||||
import Linear as L
|
||||
|
||||
-- GUI
|
||||
import qualified Graphics.UI.SDL as SDL (Position)
|
||||
import Graphics.UI.SDL as SDL
|
||||
--import Graphics.UI.SDL.TTF as TTF
|
||||
--import Graphics.UI.SDL.TTF.Types
|
||||
|
||||
-- Render
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||
import Data.Time (getCurrentTime, UTCTime, diffUTCTime)
|
||||
|
||||
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
|
||||
-- Our modules
|
||||
import Map.Graphics
|
||||
import Render.Misc (checkError,
|
||||
createFrustum, getCam,
|
||||
lookAt, up, curb)
|
||||
curb)
|
||||
import Render.Render (initRendering,
|
||||
initShader)
|
||||
import UI.Callbacks
|
||||
import Types
|
||||
|
||||
import qualified Debug.Trace as D (trace)
|
||||
|
||||
data ArrowKeyState = ArrowKeyState {
|
||||
arrowUp :: !Bool
|
||||
,arrowDown :: !Bool
|
||||
,arrowLeft :: !Bool
|
||||
,arrowRight :: !Bool
|
||||
}
|
||||
|
||||
--Static Read-Only-State
|
||||
data Env = Env
|
||||
{ envEventsChan :: TQueue Event
|
||||
, envWindow :: !Window
|
||||
, envZDistClosest :: !Double
|
||||
, envZDistFarthest :: !Double
|
||||
--, envGLContext :: !GLContext
|
||||
}
|
||||
|
||||
--Mutable State
|
||||
data State = State
|
||||
{ stateWindowWidth :: !Int
|
||||
, stateWindowHeight :: !Int
|
||||
, stateWinClose :: !Bool
|
||||
, stateClock :: !UTCTime
|
||||
--- IO
|
||||
, stateXAngle :: !Double
|
||||
, stateYAngle :: !Double
|
||||
, stateZDist :: !Double
|
||||
, stateMouseDown :: !Bool
|
||||
, stateDragging :: !Bool
|
||||
, stateDragStartX :: !Double
|
||||
, stateDragStartY :: !Double
|
||||
, stateDragStartXAngle :: !Double
|
||||
, stateDragStartYAngle :: !Double
|
||||
, statePositionX :: !Double
|
||||
, statePositionY :: !Double
|
||||
, stateCursorPosX :: !Double
|
||||
, stateCursorPosY :: !Double
|
||||
, stateArrowsPressed :: !ArrowKeyState
|
||||
, stateFrustum :: !(M44 CFloat)
|
||||
--- pointer to bindings for locations inside the compiled shader
|
||||
--- mutable because shaders may be changed in the future.
|
||||
, shdrVertexIndex :: !GL.AttribLocation
|
||||
, shdrColorIndex :: !GL.AttribLocation
|
||||
, shdrNormalIndex :: !GL.AttribLocation
|
||||
, shdrProjMatIndex :: !GL.UniformLocation
|
||||
, shdrViewMatIndex :: !GL.UniformLocation
|
||||
, shdrModelMatIndex :: !GL.UniformLocation
|
||||
, shdrNormalMatIndex :: !GL.UniformLocation
|
||||
--- the map
|
||||
, stateMap :: !GL.BufferObject
|
||||
, mapVert :: !GL.NumArrayIndices
|
||||
}
|
||||
|
||||
type Pioneers = RWST Env () State IO
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
main :: IO ()
|
||||
main = do
|
||||
SDL.withInit [InitVideo, InitAudio] $ do --also: InitNoParachute -> faster, without parachute!
|
||||
SDL.withWindow "Pioneers" (Position 1500 100) (Size 1024 768) [WindowOpengl -- we want openGL
|
||||
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)
|
||||
,WindowInputGrabbed-- never let go of input (KB/Mouse)
|
||||
] $ \window -> do
|
||||
withOpenGL window $ do
|
||||
--TTF.withInit $ do
|
||||
(Size fbWidth fbHeight) <- glGetDrawableSize window
|
||||
initRendering
|
||||
--generate map vertices
|
||||
(mapBuffer, vert) <- getMapBufferObject
|
||||
(ci, ni, vi, pri, vii, mi, nmi) <- initShader
|
||||
(ci, ni, vi, pri, vii, mi, nmi, tli, tlo) <- initShader
|
||||
putStrLn "foo"
|
||||
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
|
||||
|
||||
let zDistClosest = 10
|
||||
zDistFarthest = zDistClosest + 20
|
||||
let zDistClosest = 1
|
||||
zDistFarthest = zDistClosest + 30
|
||||
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
||||
fov = 90 --field of view
|
||||
near = 1 --near plane
|
||||
far = 100 --far plane
|
||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
||||
frust = createFrustum fov near far ratio
|
||||
aks = ArrowKeyState {
|
||||
arrowUp = False
|
||||
,arrowDown = False
|
||||
,arrowLeft = False
|
||||
,arrowRight = False
|
||||
_up = False
|
||||
, _down = False
|
||||
, _left = False
|
||||
, _right = False
|
||||
}
|
||||
glMap = GLMapState
|
||||
{ _shdrVertexIndex = vi
|
||||
, _shdrNormalIndex = ni
|
||||
, _shdrColorIndex = ci
|
||||
, _shdrProjMatIndex = pri
|
||||
, _shdrViewMatIndex = vii
|
||||
, _shdrModelMatIndex = mi
|
||||
, _shdrNormalMatIndex = nmi
|
||||
, _shdrTessInnerIndex = tli
|
||||
, _shdrTessOuterIndex = tlo
|
||||
, _stateTessellationFactor = 4
|
||||
, _stateMap = mapBuffer
|
||||
, _mapVert = vert
|
||||
}
|
||||
env = Env
|
||||
{ envEventsChan = eventQueue
|
||||
, envWindow = window
|
||||
, envZDistClosest = zDistClosest
|
||||
, envZDistFarthest = zDistFarthest
|
||||
{ _eventsChan = eventQueue
|
||||
, _windowObject = window
|
||||
, _zDistClosest = zDistClosest
|
||||
, _zDistFarthest = zDistFarthest
|
||||
--, envFont = font
|
||||
}
|
||||
state = State
|
||||
{ stateWindowWidth = fbWidth
|
||||
, stateWindowHeight = fbHeight
|
||||
, stateXAngle = pi/6
|
||||
, stateYAngle = pi/2
|
||||
, stateZDist = 10
|
||||
, statePositionX = 5
|
||||
, statePositionY = 5
|
||||
, stateCursorPosX = 0
|
||||
, stateCursorPosY = 0
|
||||
, stateMouseDown = False
|
||||
, stateDragging = False
|
||||
, stateDragStartX = 0
|
||||
, stateDragStartY = 0
|
||||
, stateDragStartXAngle = 0
|
||||
, stateDragStartYAngle = 0
|
||||
, shdrVertexIndex = vi
|
||||
, shdrNormalIndex = ni
|
||||
, shdrColorIndex = ci
|
||||
, shdrProjMatIndex = pri
|
||||
, shdrViewMatIndex = vii
|
||||
, shdrModelMatIndex = mi
|
||||
, shdrNormalMatIndex = nmi
|
||||
, stateMap = mapBuffer
|
||||
, mapVert = vert
|
||||
, stateFrustum = frust
|
||||
, stateWinClose = False
|
||||
, stateClock = now
|
||||
, stateArrowsPressed = aks
|
||||
{ _window = WindowState
|
||||
{ _width = fbWidth
|
||||
, _height = fbHeight
|
||||
, _shouldClose = False
|
||||
}
|
||||
, _camera = CameraState
|
||||
{ _xAngle = pi/6
|
||||
, _yAngle = pi/2
|
||||
, _zDist = 10
|
||||
, _frustum = frust
|
||||
, _camPosition = Types.Position
|
||||
{ Types._x = 5
|
||||
, Types._y = 5
|
||||
}
|
||||
}
|
||||
, _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
|
||||
}
|
||||
, _game = GameState
|
||||
{
|
||||
}
|
||||
}
|
||||
|
||||
putStrLn "init done."
|
||||
@ -181,47 +160,52 @@ main = do
|
||||
|
||||
draw :: Pioneers ()
|
||||
draw = do
|
||||
env <- ask
|
||||
state <- get
|
||||
let xa = stateXAngle state
|
||||
ya = stateYAngle state
|
||||
(GL.UniformLocation proj) = shdrProjMatIndex state
|
||||
(GL.UniformLocation nmat) = shdrNormalMatIndex state
|
||||
(GL.UniformLocation vmat) = shdrViewMatIndex state
|
||||
vi = shdrVertexIndex state
|
||||
ni = shdrNormalIndex state
|
||||
ci = shdrColorIndex state
|
||||
numVert = mapVert state
|
||||
map' = stateMap state
|
||||
frust = stateFrustum state
|
||||
camX = statePositionX state
|
||||
camY = statePositionY state
|
||||
zDist = stateZDist state
|
||||
let xa = state ^. camera.xAngle
|
||||
ya = state ^. camera.yAngle
|
||||
(GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
|
||||
(GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
|
||||
(GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
|
||||
(GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
|
||||
(GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
|
||||
vi = state ^. gl.glMap.shdrVertexIndex
|
||||
ni = state ^. gl.glMap.shdrNormalIndex
|
||||
ci = state ^. gl.glMap.shdrColorIndex
|
||||
numVert = state ^. gl.glMap.mapVert
|
||||
map' = state ^. gl.glMap.stateMap
|
||||
frust = state ^. camera.frustum
|
||||
camX = state ^. camera.camPosition.x
|
||||
camY = state ^. camera.camPosition.y
|
||||
zDist' = state ^. camera.zDist
|
||||
tessFac = state ^. gl.glMap.stateTessellationFactor
|
||||
liftIO $ do
|
||||
--(vi,GL.UniformLocation proj) <- initShader
|
||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||
checkError "foo"
|
||||
--set up projection (= copy from state)
|
||||
with (distribute $ frust) $ \ptr ->
|
||||
with (distribute frust) $ \ptr ->
|
||||
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
checkError "foo"
|
||||
|
||||
--set up camera
|
||||
let ! cam = getCam (camX,camY) zDist xa ya
|
||||
with (distribute $ cam) $ \ptr ->
|
||||
let ! cam = getCam (camX,camY) zDist' xa ya
|
||||
with (distribute cam) $ \ptr ->
|
||||
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||
checkError "foo"
|
||||
|
||||
--set up normal--Mat transpose((model*camera)^-1)
|
||||
let normal = (case inv33 ((fmap (^._xyz) cam) ^. _xyz) of
|
||||
let normal = (case inv33 (fmap (^. _xyz) cam ^. _xyz) of
|
||||
(Just a) -> a
|
||||
Nothing -> eye3) :: M33 CFloat
|
||||
nmap = (collect (fmap id) normal) :: M33 CFloat --transpose...
|
||||
nmap = collect id normal :: M33 CFloat --transpose...
|
||||
|
||||
with (distribute $ nmap) $ \ptr ->
|
||||
with (distribute nmap) $ \ptr ->
|
||||
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
|
||||
|
||||
checkError "nmat"
|
||||
|
||||
glUniform1f tli (fromIntegral tessFac)
|
||||
glUniform1f tlo (fromIntegral tessFac)
|
||||
|
||||
GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
|
||||
GL.vertexAttribPointer ci GL.$= fgColorIndex
|
||||
@ -231,8 +215,11 @@ draw = do
|
||||
GL.vertexAttribPointer vi GL.$= fgVertexIndex
|
||||
GL.vertexAttribArray vi GL.$= GL.Enabled
|
||||
checkError "beforeDraw"
|
||||
|
||||
glPatchParameteri gl_PATCH_VERTICES 3
|
||||
glPolygonMode gl_FRONT gl_LINE
|
||||
|
||||
GL.drawArrays GL.Triangles 0 numVert
|
||||
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
|
||||
checkError "draw"
|
||||
|
||||
|
||||
@ -240,12 +227,11 @@ draw = do
|
||||
|
||||
run :: Pioneers ()
|
||||
run = do
|
||||
win <- asks envWindow
|
||||
env <- ask
|
||||
|
||||
-- draw Scene
|
||||
draw
|
||||
liftIO $ do
|
||||
glSwapWindow win
|
||||
liftIO $ glSwapWindow (env ^. windowObject)
|
||||
-- getEvents & process
|
||||
processEvents
|
||||
|
||||
@ -253,15 +239,15 @@ run = do
|
||||
|
||||
state <- get
|
||||
-- change in camera-angle
|
||||
when (stateDragging state) $ do
|
||||
let sodx = stateDragStartX state
|
||||
sody = stateDragStartY state
|
||||
sodxa = stateDragStartXAngle state
|
||||
sodya = stateDragStartYAngle state
|
||||
x = stateCursorPosX state
|
||||
y = stateCursorPosY state
|
||||
let myrot = (x - sodx) / 2
|
||||
mxrot = (y - sody) / 2
|
||||
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
|
||||
@ -269,26 +255,23 @@ run = do
|
||||
| newYAngle' < (-pi) = newYAngle' + 2 * pi
|
||||
| otherwise = newYAngle'
|
||||
newYAngle' = sodya + myrot/100
|
||||
put $ state
|
||||
{ stateXAngle = newXAngle
|
||||
, stateYAngle = newYAngle
|
||||
}
|
||||
|
||||
modify $ ((camera.xAngle) .~ newXAngle)
|
||||
. ((camera.yAngle) .~ newYAngle)
|
||||
|
||||
-- get cursor-keys - if pressed
|
||||
--TODO: Add sin/cos from stateYAngle
|
||||
(kxrot, kyrot) <- fmap ((join (***)) fromIntegral) getArrowMovement
|
||||
modify $ \s ->
|
||||
let
|
||||
multc = cos $ stateYAngle s
|
||||
mults = sin $ stateYAngle s
|
||||
in
|
||||
s {
|
||||
statePositionX = statePositionX s - 0.2 * kxrot * multc
|
||||
- 0.2 * kyrot * mults
|
||||
, statePositionY = statePositionY s + 0.2 * kxrot * mults
|
||||
- 0.2 * kyrot * multc
|
||||
}
|
||||
|
||||
(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.camPosition.x %~ modx)
|
||||
. (camera.camPosition.y %~ mody)
|
||||
|
||||
{-
|
||||
--modify the state with all that happened in mt time.
|
||||
mt <- liftIO GLFW.getTime
|
||||
@ -296,47 +279,45 @@ run = do
|
||||
{
|
||||
}
|
||||
-}
|
||||
|
||||
mt <- liftIO $ do
|
||||
now <- getCurrentTime
|
||||
diff <- return $ diffUTCTime now (stateClock state) -- get time-diffs
|
||||
diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
|
||||
title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 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 $ \s -> s
|
||||
{
|
||||
stateClock = mt
|
||||
}
|
||||
shouldClose <- return $ stateWinClose state
|
||||
modify $ io.clock .~ mt
|
||||
shouldClose <- return $ state ^. window.shouldClose
|
||||
unless shouldClose run
|
||||
|
||||
getArrowMovement :: Pioneers (Int, Int)
|
||||
getArrowMovement = do
|
||||
state <- get
|
||||
aks <- return $ stateArrowsPressed state
|
||||
aks <- return $ state ^. (keyboard.arrowsPressed)
|
||||
let
|
||||
horz = left' + right'
|
||||
vert = up'+down'
|
||||
left' = if arrowLeft aks then -1 else 0
|
||||
right' = if arrowRight aks then 1 else 0
|
||||
up' = if arrowUp aks then -1 else 0
|
||||
down' = if arrowDown aks then 1 else 0
|
||||
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 = stateWindowWidth state
|
||||
fbHeight = stateWindowHeight state
|
||||
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)
|
||||
put $ state {
|
||||
stateFrustum = frust
|
||||
}
|
||||
modify $ camera.frustum .~ frust
|
||||
|
||||
|
||||
processEvents :: Pioneers ()
|
||||
@ -350,74 +331,78 @@ processEvents = do
|
||||
|
||||
processEvent :: Event -> Pioneers ()
|
||||
processEvent e = do
|
||||
return ()
|
||||
case eventData e of
|
||||
Window _ winEvent ->
|
||||
case winEvent of
|
||||
Closing -> modify $ \s -> s {
|
||||
stateWinClose = True
|
||||
}
|
||||
_ -> return ()
|
||||
Keyboard movement _ repeat key -> --up/down window(ignored) true/false actualKey
|
||||
-- need modifiers? use "keyModifiers key" to get them
|
||||
case keyScancode key of
|
||||
Escape -> modify $ \s -> s {
|
||||
stateWinClose = True
|
||||
}
|
||||
SDL.Left -> modify $ \s -> s {
|
||||
stateArrowsPressed = (stateArrowsPressed s) {
|
||||
arrowLeft = movement == KeyDown
|
||||
}
|
||||
}
|
||||
SDL.Right -> modify $ \s -> s {
|
||||
stateArrowsPressed = (stateArrowsPressed s) {
|
||||
arrowRight = movement == KeyDown
|
||||
}
|
||||
}
|
||||
SDL.Up -> modify $ \s -> s {
|
||||
stateArrowsPressed = (stateArrowsPressed s) {
|
||||
arrowUp = movement == KeyDown
|
||||
}
|
||||
}
|
||||
SDL.Down -> modify $ \s -> s {
|
||||
stateArrowsPressed = (stateArrowsPressed s) {
|
||||
arrowDown = movement == KeyDown
|
||||
}
|
||||
}
|
||||
_ -> return ()
|
||||
MouseMotion _ id st (Position x y) xrel yrel -> do
|
||||
state <- get
|
||||
when (stateMouseDown state && not (stateDragging state)) $
|
||||
put $ state
|
||||
{ stateDragging = True
|
||||
, stateDragStartX = fromIntegral x
|
||||
, stateDragStartY = fromIntegral y
|
||||
, stateDragStartXAngle = stateXAngle state
|
||||
, stateDragStartYAngle = stateYAngle state
|
||||
}
|
||||
modify $ \s -> s {
|
||||
stateCursorPosX = fromIntegral x
|
||||
, stateCursorPosY = fromIntegral y
|
||||
}
|
||||
MouseButton _ id button state (Position x y) ->
|
||||
case button of
|
||||
LeftButton -> do
|
||||
let pressed = state == Pressed
|
||||
modify $ \s -> s
|
||||
{ stateMouseDown = pressed
|
||||
}
|
||||
unless pressed $
|
||||
modify $ \s -> s
|
||||
{ stateDragging = False
|
||||
}
|
||||
_ -> return ()
|
||||
MouseWheel _ id hscroll vscroll -> do
|
||||
env <- ask
|
||||
modify $ \s -> s
|
||||
{ stateZDist =
|
||||
let zDist' = stateZDist s + realToFrac (negate $ vscroll)
|
||||
in curb (envZDistClosest env) (envZDistFarthest env) zDist'
|
||||
}
|
||||
Quit -> modify $ \s -> s {stateWinClose = True}
|
||||
-- there is more (joystic, touchInterface, ...), but currently ignored
|
||||
_ -> return ()
|
||||
liftIO $ putStrLn $ unwords ["Processing Event:",(show e)]
|
||||
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
|
||||
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
|
||||
env <- ask
|
||||
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]
|
||||
|
||||
@ -79,6 +79,11 @@ getMapBufferObject = do
|
||||
checkError "initBuffer"
|
||||
return (bo,len)
|
||||
|
||||
prettyMap :: [GLfloat] -> [(GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat,GLfloat)]
|
||||
prettyMap (a:b:c:d:x:y:z:u:v:w:ms) = (a,b,c,d,x,y,z,u,v,w):(prettyMap ms)
|
||||
prettyMap _ = []
|
||||
|
||||
--generateTriangles :: PlayMap -> [GLfloat]
|
||||
generateTriangles :: GraphicsMap -> [GLfloat]
|
||||
generateTriangles map' =
|
||||
let ((xl,yl),(xh,yh)) = bounds map' in
|
||||
@ -179,7 +184,7 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
|
||||
Mountain -> (0.5, 0.5, 0.5)
|
||||
|
||||
coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
|
||||
coordLookup (x,z) y =
|
||||
coordLookup (x,z) y =
|
||||
if even x then
|
||||
V3 (fromIntegral $ x `div` 2) y (fromIntegral (2 * z) * lineHeight)
|
||||
else
|
||||
|
||||
@ -1,10 +1,8 @@
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
module Render.Misc where
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString as B (ByteString)
|
||||
import Foreign.Marshal.Array (allocaArray,
|
||||
pokeArray)
|
||||
import Foreign.C (CFloat)
|
||||
import Graphics.Rendering.OpenGL.GL.Shaders
|
||||
import Graphics.Rendering.OpenGL.GL.StateVar
|
||||
import Graphics.Rendering.OpenGL.GL.StringQueries
|
||||
@ -12,7 +10,7 @@ import Graphics.Rendering.OpenGL.GLU.Errors
|
||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||
import System.IO (hPutStrLn, stderr)
|
||||
import Linear
|
||||
|
||||
import Foreign.C (CFloat)
|
||||
|
||||
up :: V3 CFloat
|
||||
up = V3 0 1 0
|
||||
|
||||
@ -18,6 +18,10 @@ import Render.Misc
|
||||
|
||||
vertexShaderFile :: String
|
||||
vertexShaderFile = "shaders/vertex.shader"
|
||||
tessControlShaderFile :: String
|
||||
tessControlShaderFile = "shaders/tessControl.shader"
|
||||
tessEvalShaderFile :: String
|
||||
tessEvalShaderFile = "shaders/tessEval.shader"
|
||||
fragmentShaderFile :: String
|
||||
fragmentShaderFile = "shaders/fragment.shader"
|
||||
|
||||
@ -42,40 +46,55 @@ initShader :: IO (
|
||||
, UniformLocation -- ^ ViewMat
|
||||
, UniformLocation -- ^ ModelMat
|
||||
, UniformLocation -- ^ NormalMat
|
||||
, UniformLocation -- ^ TessLevelInner
|
||||
, UniformLocation -- ^ TessLevelOuter
|
||||
)
|
||||
initShader = do
|
||||
! vertexSource <- B.readFile vertexShaderFile
|
||||
! tessControlSource <- B.readFile tessControlShaderFile
|
||||
! tessEvalSource <- B.readFile tessEvalShaderFile
|
||||
! fragmentSource <- B.readFile fragmentShaderFile
|
||||
vertexShader <- compileShaderSource VertexShader vertexSource
|
||||
checkError "compile Vertex"
|
||||
tessControlShader <- compileShaderSource TessControlShader tessControlSource
|
||||
checkError "compile Vertex"
|
||||
tessEvalShader <- compileShaderSource TessEvaluationShader tessEvalSource
|
||||
checkError "compile Vertex"
|
||||
fragmentShader <- compileShaderSource FragmentShader fragmentSource
|
||||
checkError "compile Frag"
|
||||
program <- createProgramUsing [vertexShader, fragmentShader]
|
||||
program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
|
||||
checkError "compile Program"
|
||||
|
||||
currentProgram $= Just program
|
||||
|
||||
projectionMatrixIndex <- get (uniformLocation program "fg_ProjectionMatrix")
|
||||
projectionMatrixIndex <- get (uniformLocation program "ProjectionMatrix")
|
||||
checkError "projMat"
|
||||
|
||||
viewMatrixIndex <- get (uniformLocation program "fg_ViewMatrix")
|
||||
viewMatrixIndex <- get (uniformLocation program "ViewMatrix")
|
||||
checkError "viewMat"
|
||||
|
||||
modelMatrixIndex <- get (uniformLocation program "fg_ModelMatrix")
|
||||
modelMatrixIndex <- get (uniformLocation program "ModelMatrix")
|
||||
checkError "modelMat"
|
||||
|
||||
normalMatrixIndex <- get (uniformLocation program "fg_NormalMatrix")
|
||||
normalMatrixIndex <- get (uniformLocation program "NormalMatrix")
|
||||
checkError "normalMat"
|
||||
|
||||
vertexIndex <- get (attribLocation program "fg_VertexIn")
|
||||
tessLevelInner <- get (uniformLocation program "TessLevelInner")
|
||||
checkError "TessLevelInner"
|
||||
|
||||
tessLevelOuter <- get (uniformLocation program "TessLevelOuter")
|
||||
checkError "TessLevelOuter"
|
||||
|
||||
|
||||
vertexIndex <- get (attribLocation program "Position")
|
||||
vertexAttribArray vertexIndex $= Enabled
|
||||
checkError "vertexInd"
|
||||
|
||||
normalIndex <- get (attribLocation program "fg_NormalIn")
|
||||
normalIndex <- get (attribLocation program "Normal")
|
||||
vertexAttribArray normalIndex $= Enabled
|
||||
checkError "normalInd"
|
||||
|
||||
colorIndex <- get (attribLocation program "fg_Color")
|
||||
colorIndex <- get (attribLocation program "Color")
|
||||
vertexAttribArray colorIndex $= Enabled
|
||||
checkError "colorInd"
|
||||
|
||||
@ -85,7 +104,7 @@ initShader = do
|
||||
putStrLn $ unlines $ ["Indices: ", show (colorIndex, normalIndex, vertexIndex)]
|
||||
|
||||
checkError "initShader"
|
||||
return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex)
|
||||
return (colorIndex, normalIndex, vertexIndex, projectionMatrixIndex, viewMatrixIndex, modelMatrixIndex, normalMatrixIndex, tessLevelInner, tessLevelOuter)
|
||||
|
||||
initRendering :: IO ()
|
||||
initRendering = do
|
||||
|
||||
118
src/Types.hs
Normal file
118
src/Types.hs
Normal file
@ -0,0 +1,118 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Types where
|
||||
|
||||
import Control.Concurrent.STM (TQueue)
|
||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||
import Graphics.UI.SDL as SDL (Event, Window)
|
||||
import Foreign.C (CFloat)
|
||||
import Data.Time (UTCTime)
|
||||
import Linear.Matrix (M44)
|
||||
import Control.Monad.RWS.Strict (RWST)
|
||||
import Control.Lens
|
||||
import Data.Label
|
||||
|
||||
|
||||
--Static Read-Only-State
|
||||
data Env = Env
|
||||
{ _eventsChan :: TQueue Event
|
||||
, _windowObject :: !Window
|
||||
, _zDistClosest :: !Double
|
||||
, _zDistFarthest :: !Double
|
||||
--, envGLContext :: !GLContext
|
||||
--, envFont :: TTF.TTFFont
|
||||
}
|
||||
|
||||
--Mutable State
|
||||
|
||||
data Position = Position
|
||||
{ _x :: !Double
|
||||
, _y :: !Double
|
||||
}
|
||||
|
||||
data WindowState = WindowState
|
||||
{ _width :: !Int
|
||||
, _height :: !Int
|
||||
, _shouldClose :: !Bool
|
||||
}
|
||||
|
||||
data CameraState = CameraState
|
||||
{ _xAngle :: !Double
|
||||
, _yAngle :: !Double
|
||||
, _zDist :: !Double
|
||||
, _frustum :: !(M44 CFloat)
|
||||
, _camPosition :: !Position --TODO: Get rid of cam-prefix
|
||||
}
|
||||
|
||||
data IOState = IOState
|
||||
{ _clock :: !UTCTime
|
||||
}
|
||||
|
||||
data GameState = GameState
|
||||
{
|
||||
}
|
||||
|
||||
data MouseState = MouseState
|
||||
{ _isDown :: !Bool
|
||||
, _isDragging :: !Bool
|
||||
, _dragStartX :: !Double
|
||||
, _dragStartY :: !Double
|
||||
, _dragStartXAngle :: !Double
|
||||
, _dragStartYAngle :: !Double
|
||||
, _mousePosition :: !Position --TODO: Get rid of mouse-prefix
|
||||
}
|
||||
|
||||
data ArrowKeyState = ArrowKeyState {
|
||||
_up :: !Bool
|
||||
,_down :: !Bool
|
||||
,_left :: !Bool
|
||||
,_right :: !Bool
|
||||
}
|
||||
|
||||
data KeyboardState = KeyboardState
|
||||
{ _arrowsPressed :: !ArrowKeyState
|
||||
}
|
||||
|
||||
data GLMapState = GLMapState
|
||||
{ _shdrVertexIndex :: !GL.AttribLocation
|
||||
, _shdrColorIndex :: !GL.AttribLocation
|
||||
, _shdrNormalIndex :: !GL.AttribLocation
|
||||
, _shdrProjMatIndex :: !GL.UniformLocation
|
||||
, _shdrViewMatIndex :: !GL.UniformLocation
|
||||
, _shdrModelMatIndex :: !GL.UniformLocation
|
||||
, _shdrNormalMatIndex :: !GL.UniformLocation
|
||||
, _shdrTessInnerIndex :: !GL.UniformLocation
|
||||
, _shdrTessOuterIndex :: !GL.UniformLocation
|
||||
, _stateTessellationFactor :: !Int
|
||||
, _stateMap :: !GL.BufferObject
|
||||
, _mapVert :: !GL.NumArrayIndices
|
||||
}
|
||||
|
||||
data GLState = GLState
|
||||
{ _glMap :: !GLMapState
|
||||
}
|
||||
|
||||
data State = State
|
||||
{ _window :: !WindowState
|
||||
, _camera :: !CameraState
|
||||
, _io :: !IOState
|
||||
, _mouse :: !MouseState
|
||||
, _keyboard :: !KeyboardState
|
||||
, _gl :: !GLState
|
||||
, _game :: !GameState
|
||||
}
|
||||
|
||||
$(makeLenses ''State)
|
||||
$(makeLenses ''GLState)
|
||||
$(makeLenses ''GLMapState)
|
||||
$(makeLenses ''KeyboardState)
|
||||
$(makeLenses ''ArrowKeyState)
|
||||
$(makeLenses ''MouseState)
|
||||
$(makeLenses ''GameState)
|
||||
$(makeLenses ''IOState)
|
||||
$(makeLenses ''CameraState)
|
||||
$(makeLenses ''WindowState)
|
||||
$(makeLenses ''Position)
|
||||
$(makeLenses ''Env)
|
||||
|
||||
|
||||
type Pioneers = RWST Env () State IO
|
||||
20
src/UI/Callbacks.hs
Normal file
20
src/UI/Callbacks.hs
Normal file
@ -0,0 +1,20 @@
|
||||
module UI.Callbacks where
|
||||
|
||||
import Control.Monad.Trans (liftIO)
|
||||
import Types
|
||||
|
||||
data Pixel = Pixel Int Int
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates a primary click on something (e.g. left-click, touch on Touchpad, fire on Gamepad, ...
|
||||
clickHandler :: Pixel -> Pioneers ()
|
||||
clickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["button press on (",show x,",",show y,")"]
|
||||
|
||||
-- | Handler for UI-Inputs.
|
||||
-- Indicates an alternate click on something (e.g. right-click, touch&hold on Touchpad, ...
|
||||
alternateClickHandler :: Pixel -> Pioneers ()
|
||||
alternateClickHandler (Pixel x y) = liftIO $ putStrLn $ unwords ["alternate press on (",show x,",",show y,")"]
|
||||
|
||||
|
||||
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
|
||||
--TODO: Maybe queues are better?
|
||||
Reference in New Issue
Block a user