Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

works again like the prototype

Browse Source
This commit is contained in:
Nicole Dresselhaus 2014-01-20 23:18:07 +01:00
parent 83c487c65d
commit 33b06a787d
2 changed files with 100 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
src/Main.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
module Main where module Main where
-- Monad-foo -- Monad-foo and higher functional stuff
import Control.Applicative import Control.Applicative
import Control.Monad (unless, void, when) import Control.Monad (unless, void, when, join)
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
import Control.Arrow ((***))
-- data consistency/conversion -- data consistency/conversion
import Control.Concurrent (threadDelay) import Control.Concurrent (threadDelay)
@ -38,12 +39,19 @@ import Data.Time (getCurrentTime, UTCTime,
import Map.Map import Map.Map
import Render.Misc (checkError, import Render.Misc (checkError,
createFrustum, getCam, createFrustum, getCam,
lookAt, up) lookAt, up, curb)
import Render.Render (initRendering, import Render.Render (initRendering,
initShader) initShader)
import qualified Debug.Trace as D (trace) import qualified Debug.Trace as D (trace)
data ArrowKeyState = ArrowKeyState {
arrowUp :: !Bool
,arrowDown :: !Bool
,arrowLeft :: !Bool
,arrowRight :: !Bool
}
--Static Read-Only-State --Static Read-Only-State
data Env = Env data Env = Env
{ envEventsChan :: TQueue Event { envEventsChan :: TQueue Event
@ -71,6 +79,9 @@ data State = State
, stateDragStartYAngle :: !Double , stateDragStartYAngle :: !Double
, statePositionX :: !Double , statePositionX :: !Double
, statePositionY :: !Double , statePositionY :: !Double
, stateCursorPosX :: !Double
, stateCursorPosY :: !Double
, stateArrowsPressed :: !ArrowKeyState
, stateFrustum :: !(M44 CFloat) , stateFrustum :: !(M44 CFloat)
--- pointer to bindings for locations inside the compiled shader --- pointer to bindings for locations inside the compiled shader
--- mutable because shaders may be changed in the future. --- mutable because shaders may be changed in the future.
@ -118,6 +129,12 @@ main = do
far = 100 --far plane far = 100 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
aks = ArrowKeyState {
arrowUp = False
,arrowDown = False
,arrowLeft = False
,arrowRight = False
}
env = Env env = Env
{ envEventsChan = eventQueue { envEventsChan = eventQueue
, envWindow = window , envWindow = window
@ -132,6 +149,8 @@ main = do
, stateZDist = 10 , stateZDist = 10
, statePositionX = 5 , statePositionX = 5
, statePositionY = 5 , statePositionY = 5
, stateCursorPosX = 0
, stateCursorPosY = 0
, stateMouseDown = False , stateMouseDown = False
, stateDragging = False , stateDragging = False
, stateDragStartX = 0 , stateDragStartX = 0
@ -150,6 +169,7 @@ main = do
, stateFrustum = frust , stateFrustum = frust
, stateWinClose = False , stateWinClose = False
, stateClock = now , stateClock = now
, stateArrowsPressed = aks
} }
putStrLn "init done." putStrLn "init done."
@ -233,13 +253,13 @@ run = do
state <- get state <- get
-- change in camera-angle -- change in camera-angle
{- if stateDragging state when (stateDragging state) $ do
then do
let sodx = stateDragStartX state let sodx = stateDragStartX state
sody = stateDragStartY state sody = stateDragStartY state
sodxa = stateDragStartXAngle state sodxa = stateDragStartXAngle state
sodya = stateDragStartYAngle state sodya = stateDragStartYAngle state
(x, y) <- liftIO $ GLFW.getCursorPos win x = stateCursorPosX state
y = stateCursorPosY state
let myrot = (x - sodx) / 2 let myrot = (x - sodx) / 2
mxrot = (y - sody) / 2 mxrot = (y - sody) / 2
newXAngle = curb (pi/12) (0.45*pi) newXAngle' newXAngle = curb (pi/12) (0.45*pi) newXAngle'
@ -253,17 +273,10 @@ run = do
{ stateXAngle = newXAngle { stateXAngle = newXAngle
, stateYAngle = newYAngle , stateYAngle = newYAngle
} }
-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
else do
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
put $ state
{ stateXAngle = stateXAngle state + (2 * jxrot)
, stateYAngle = stateYAngle state + (2 * jyrot)
}
-- get cursor-keys - if pressed -- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle --TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win (kxrot, kyrot) <- fmap ((join (***)) fromIntegral) getArrowMovement
modify $ \s -> modify $ \s ->
let let
multc = cos $ stateYAngle s multc = cos $ stateYAngle s
@ -275,7 +288,7 @@ run = do
, statePositionY = statePositionY s + 0.2 * kxrot * mults , statePositionY = statePositionY s + 0.2 * kxrot * mults
- 0.2 * kyrot * multc - 0.2 * kyrot * multc
} }
-}
{- {-
--modify the state with all that happened in mt time. --modify the state with all that happened in mt time.
mt <- liftIO GLFW.getTime mt <- liftIO GLFW.getTime
@ -297,6 +310,19 @@ run = do
shouldClose <- return $ stateWinClose state shouldClose <- return $ stateWinClose state
unless shouldClose run unless shouldClose run
getArrowMovement :: Pioneers (Int, Int)
getArrowMovement = do
state <- get
aks <- return $ stateArrowsPressed state
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
return (horz,vert)
adjustWindow :: Pioneers () adjustWindow :: Pioneers ()
adjustWindow = do adjustWindow = do
state <- get state <- get
@ -337,13 +363,60 @@ processEvent e = do
Escape -> modify $ \s -> s { Escape -> modify $ \s -> s {
stateWinClose = True 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 () _ -> return ()
MouseMotion _ id st pos xrel yrel -> MouseMotion _ id st (Position x y) xrel yrel -> do
return () state <- get
MouseButton _ id button state pos -> when (stateMouseDown state && not (stateDragging state)) $
return () put $ state
MouseWheel _ id hscroll vscroll -> { stateDragging = True
return () , 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} Quit -> modify $ \s -> s {stateWinClose = True}
-- there is more (joystic, touchInterface, ...), but currently ignored -- there is more (joystic, touchInterface, ...), but currently ignored
_ -> return () _ -> return ()

5
src/Render/Misc.hs
View File

@ -113,3 +113,8 @@ getCam (x',z') dist' xa' ya' = lookAt (cpos ^+^ at') at' up
xa = realToFrac xa' xa = realToFrac xa'
ya = realToFrac ya' ya = realToFrac ya'
curb :: Ord a => a -> a -> a -> a
curb l h x
| x < l = l
| x > h = h
| otherwise = x