cleaned up
- removed unused imports - removed unneccessary $ - removed unneccessary () - changed variables hiding functions
This commit is contained in:
parent
0d887354d5
commit
02c02454fd
53
src/Main.hs
53
src/Main.hs
@ -2,18 +2,14 @@
|
|||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
-- Monad-foo and higher functional stuff
|
-- Monad-foo and higher functional stuff
|
||||||
import Control.Applicative
|
|
||||||
import Control.Monad (unless, void, when, join)
|
import Control.Monad (unless, void, when, join)
|
||||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
|
|
||||||
-- data consistency/conversion
|
-- data consistency/conversion
|
||||||
import Control.Concurrent (threadDelay)
|
import Control.Concurrent (threadDelay)
|
||||||
import Control.Concurrent.STM (TQueue, atomically,
|
import Control.Concurrent.STM (TQueue,
|
||||||
newTQueueIO,
|
newTQueueIO)
|
||||||
tryReadTQueue,
|
|
||||||
writeTQueue, isEmptyTQueue,
|
|
||||||
STM)
|
|
||||||
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
||||||
evalRWST, get, liftIO,
|
evalRWST, get, liftIO,
|
||||||
modify, put)
|
modify, put)
|
||||||
@ -24,7 +20,7 @@ import Foreign (Ptr, castPtr, with)
|
|||||||
import Foreign.C (CFloat)
|
import Foreign.C (CFloat)
|
||||||
|
|
||||||
-- Math
|
-- Math
|
||||||
import Control.Lens (transposeOf, (^.))
|
import Control.Lens ((^.))
|
||||||
import Linear as L
|
import Linear as L
|
||||||
|
|
||||||
-- GUI
|
-- GUI
|
||||||
@ -40,7 +36,7 @@ import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
|
|||||||
import Map.Map
|
import Map.Map
|
||||||
import Render.Misc (checkError,
|
import Render.Misc (checkError,
|
||||||
createFrustum, getCam,
|
createFrustum, getCam,
|
||||||
lookAt, up, curb)
|
curb)
|
||||||
import Render.Render (initRendering,
|
import Render.Render (initRendering,
|
||||||
initShader)
|
initShader)
|
||||||
|
|
||||||
@ -128,6 +124,7 @@ main = do
|
|||||||
|
|
||||||
let zDistClosest = 1
|
let zDistClosest = 1
|
||||||
zDistFarthest = zDistClosest + 30
|
zDistFarthest = zDistClosest + 30
|
||||||
|
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
||||||
fov = 90 --field of view
|
fov = 90 --field of view
|
||||||
near = 1 --near plane
|
near = 1 --near plane
|
||||||
far = 100 --far plane
|
far = 100 --far plane
|
||||||
@ -188,7 +185,6 @@ main = do
|
|||||||
|
|
||||||
draw :: Pioneers ()
|
draw :: Pioneers ()
|
||||||
draw = do
|
draw = do
|
||||||
env <- ask
|
|
||||||
state <- get
|
state <- get
|
||||||
let xa = stateXAngle state
|
let xa = stateXAngle state
|
||||||
ya = stateYAngle state
|
ya = stateYAngle state
|
||||||
@ -212,23 +208,23 @@ draw = do
|
|||||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
||||||
checkError "foo"
|
checkError "foo"
|
||||||
--set up projection (= copy from state)
|
--set up projection (= copy from state)
|
||||||
with (distribute $ frust) $ \ptr ->
|
with (distribute frust) $ \ptr ->
|
||||||
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||||
checkError "foo"
|
checkError "foo"
|
||||||
|
|
||||||
--set up camera
|
--set up camera
|
||||||
let ! cam = getCam (camX,camY) zDist xa ya
|
let ! cam = getCam (camX,camY) zDist xa ya
|
||||||
with (distribute $ cam) $ \ptr ->
|
with (distribute cam) $ \ptr ->
|
||||||
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
||||||
checkError "foo"
|
checkError "foo"
|
||||||
|
|
||||||
--set up normal--Mat transpose((model*camera)^-1)
|
--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
|
(Just a) -> a
|
||||||
Nothing -> eye3) :: M33 CFloat
|
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)))
|
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
|
||||||
|
|
||||||
checkError "nmat"
|
checkError "nmat"
|
||||||
@ -260,8 +256,7 @@ run = do
|
|||||||
|
|
||||||
-- draw Scene
|
-- draw Scene
|
||||||
draw
|
draw
|
||||||
liftIO $ do
|
liftIO $ glSwapWindow win
|
||||||
glSwapWindow win
|
|
||||||
-- getEvents & process
|
-- getEvents & process
|
||||||
processEvents
|
processEvents
|
||||||
|
|
||||||
@ -292,7 +287,7 @@ run = do
|
|||||||
|
|
||||||
-- get cursor-keys - if pressed
|
-- get cursor-keys - if pressed
|
||||||
--TODO: Add sin/cos from stateYAngle
|
--TODO: Add sin/cos from stateYAngle
|
||||||
(kxrot, kyrot) <- fmap ((join (***)) fromIntegral) getArrowMovement
|
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
|
||||||
modify $ \s ->
|
modify $ \s ->
|
||||||
let
|
let
|
||||||
multc = cos $ stateYAngle s
|
multc = cos $ stateYAngle s
|
||||||
@ -315,8 +310,8 @@ run = do
|
|||||||
mt <- liftIO $ do
|
mt <- liftIO $ do
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
diff <- return $ diffUTCTime now (stateClock state) -- get time-diffs
|
diff <- return $ diffUTCTime now (stateClock state) -- get time-diffs
|
||||||
title <- return $ unwords ["Pioneers @ ",show $ ((round .fromRational.toRational $ 1/diff)::Int),"fps"]
|
title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"]
|
||||||
setWindowTitle win $ title
|
setWindowTitle win title
|
||||||
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
|
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
|
||||||
threadDelay sleepAmount
|
threadDelay sleepAmount
|
||||||
return now
|
return now
|
||||||
@ -384,8 +379,8 @@ processEvent e = do
|
|||||||
SizeChanged ->
|
SizeChanged ->
|
||||||
adjustWindow
|
adjustWindow
|
||||||
_ ->
|
_ ->
|
||||||
liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",(show e)]
|
liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
|
||||||
Keyboard movement _ repeat key -> --up/down window(ignored) true/false actualKey
|
Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey
|
||||||
-- need modifiers? use "keyModifiers key" to get them
|
-- need modifiers? use "keyModifiers key" to get them
|
||||||
case keyScancode key of
|
case keyScancode key of
|
||||||
Escape ->
|
Escape ->
|
||||||
@ -419,20 +414,20 @@ processEvent e = do
|
|||||||
SDL.KeypadPlus ->
|
SDL.KeypadPlus ->
|
||||||
when (movement == KeyDown) $ do
|
when (movement == KeyDown) $ do
|
||||||
modify $ \s -> s {
|
modify $ \s -> s {
|
||||||
stateTessellationFactor = min ((stateTessellationFactor s)+1) 5
|
stateTessellationFactor = min (stateTessellationFactor s + 1) 5
|
||||||
}
|
}
|
||||||
state <- get
|
state <- get
|
||||||
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
|
||||||
SDL.KeypadMinus ->
|
SDL.KeypadMinus ->
|
||||||
when (movement == KeyDown) $ do
|
when (movement == KeyDown) $ do
|
||||||
modify $ \s -> s {
|
modify $ \s -> s {
|
||||||
stateTessellationFactor = max ((stateTessellationFactor s)-1) 1
|
stateTessellationFactor = max (stateTessellationFactor s - 1) 1
|
||||||
}
|
}
|
||||||
state <- get
|
state <- get
|
||||||
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
MouseMotion _ id st (Position x y) xrel yrel -> do
|
MouseMotion _ mouseId st (Position x y) xrel yrel -> do
|
||||||
state <- get
|
state <- get
|
||||||
when (stateMouseDown state && not (stateDragging state)) $
|
when (stateMouseDown state && not (stateDragging state)) $
|
||||||
put $ state
|
put $ state
|
||||||
@ -446,7 +441,7 @@ processEvent e = do
|
|||||||
stateCursorPosX = fromIntegral x
|
stateCursorPosX = fromIntegral x
|
||||||
, stateCursorPosY = fromIntegral y
|
, stateCursorPosY = fromIntegral y
|
||||||
}
|
}
|
||||||
MouseButton _ id button state (Position x y) ->
|
MouseButton _ mouseId button state (Position x y) ->
|
||||||
case button of
|
case button of
|
||||||
LeftButton -> do
|
LeftButton -> do
|
||||||
let pressed = state == Pressed
|
let pressed = state == Pressed
|
||||||
@ -459,13 +454,13 @@ processEvent e = do
|
|||||||
}
|
}
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
MouseWheel _ id hscroll vscroll -> do
|
MouseWheel _ mouseId hscroll vscroll -> do
|
||||||
env <- ask
|
env <- ask
|
||||||
modify $ \s -> s
|
modify $ \s -> s
|
||||||
{ stateZDist =
|
{ stateZDist =
|
||||||
let zDist' = stateZDist s + realToFrac (negate $ vscroll)
|
let zDist' = stateZDist s + realToFrac (negate vscroll)
|
||||||
in curb (envZDistClosest env) (envZDistFarthest env) zDist'
|
in curb (envZDistClosest env) (envZDistFarthest env) zDist'
|
||||||
}
|
}
|
||||||
Quit -> modify $ \s -> s {stateWinClose = True}
|
Quit -> modify $ \s -> s {stateWinClose = True}
|
||||||
-- there is more (joystic, touchInterface, ...), but currently ignored
|
-- there is more (joystic, touchInterface, ...), but currently ignored
|
||||||
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:",(show e)]
|
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
|
||||||
Loading…
Reference in New Issue
Block a user