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

converted to lenses

Browse Source
This commit is contained in:
Stefan Dresselhaus
2014-03-05 14:42:26 +01:00
parent 82e9b4d826
commit 5a70a22da6
2 changed files with 106 additions and 135 deletions
Download Patch File Download Diff File Expand all files Collapse all files

217
src/Main.hs
View File

@@ -20,11 +20,12 @@ import Foreign (Ptr, castPtr, with)
import Foreign.C (CFloat) import Foreign.C (CFloat)
-- Math -- Math
import Control.Lens ((^.)) import Control.Lens ((^.), (.~), (%~))
import Linear as L import Linear as L
-- GUI -- GUI
import Graphics.UI.SDL as SDL hiding (Position) 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 as TTF
--import Graphics.UI.SDL.TTF.Types --import Graphics.UI.SDL.TTF.Types
@@ -50,7 +51,7 @@ import qualified Debug.Trace as D (trace)
main :: IO () main :: IO ()
main = do main = do
SDL.withInit [InitVideo, InitAudio] $ do --also: InitNoParachute -> faster, without parachute! SDL.withInit [InitVideo, InitAudio] $ do --also: InitNoParachute -> faster, without parachute!
SDL.withWindow "Pioneers" (Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
,WindowShown -- window should be visible ,WindowShown -- window should be visible
,WindowResizable -- and resizable ,WindowResizable -- and resizable
,WindowInputFocus -- focused (=> active) ,WindowInputFocus -- focused (=> active)
@@ -119,7 +120,7 @@ main = do
, _yAngle = pi/2 , _yAngle = pi/2
, _zDist = 10 , _zDist = 10
, _frustum = frust , _frustum = frust
, _camPosition = Position , _camPosition = Types.Position
{ Types._x = 5 { Types._x = 5
, Types._y = 5 , Types._y = 5
} }
@@ -134,7 +135,7 @@ main = do
, _dragStartY = 0 , _dragStartY = 0
, _dragStartXAngle = 0 , _dragStartXAngle = 0
, _dragStartYAngle = 0 , _dragStartYAngle = 0
, _mousePosition = Position , _mousePosition = Types.Position
{ Types._x = 5 { Types._x = 5
, Types._y = 5 , Types._y = 5
} }
@@ -160,23 +161,23 @@ main = do
draw :: Pioneers () draw :: Pioneers ()
draw = do draw = do
state <- get state <- get
let xa = get (camera . xAngle) state --stateXAngle state let xa = state ^. camera.xAngle
ya = stateYAngle state ya = state ^. camera.yAngle
(GL.UniformLocation proj) = shdrProjMatIndex state (GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
(GL.UniformLocation nmat) = shdrNormalMatIndex state (GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
(GL.UniformLocation vmat) = shdrViewMatIndex state (GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
(GL.UniformLocation tli) = shdrTessInnerIndex state (GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
(GL.UniformLocation tlo) = shdrTessOuterIndex state (GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
vi = shdrVertexIndex state vi = state ^. gl.glMap.shdrVertexIndex
ni = shdrNormalIndex state ni = state ^. gl.glMap.shdrNormalIndex
ci = shdrColorIndex state ci = state ^. gl.glMap.shdrColorIndex
numVert = mapVert state numVert = state ^. gl.glMap.mapVert
map' = stateMap state map' = state ^. gl.glMap.stateMap
frust = stateFrustum state frust = state ^. camera.frustum
camX = statePositionX state camX = state ^. camera.camPosition.x
camY = statePositionY state camY = state ^. camera.camPosition.y
zDist = stateZDist state zDist' = state ^. camera.zDist
tessFac = stateTessellationFactor state tessFac = state ^. gl.glMap.stateTessellationFactor
liftIO $ do liftIO $ do
--(vi,GL.UniformLocation proj) <- initShader --(vi,GL.UniformLocation proj) <- initShader
GL.clear [GL.ColorBuffer, GL.DepthBuffer] GL.clear [GL.ColorBuffer, GL.DepthBuffer]
@@ -187,7 +188,7 @@ draw = do
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"
@@ -226,11 +227,11 @@ draw = do
run :: Pioneers () run :: Pioneers ()
run = do run = do
win <- asks envWindow env <- ask
-- draw Scene -- draw Scene
draw draw
liftIO $ glSwapWindow win liftIO $ glSwapWindow (env ^. windowObject)
-- getEvents & process -- getEvents & process
processEvents processEvents
@@ -238,15 +239,15 @@ run = do
state <- get state <- get
-- change in camera-angle -- change in camera-angle
when (stateDragging state) $ do when (state ^. mouse.isDragging) $ do
let sodx = stateDragStartX state let sodx = state ^. mouse.dragStartX
sody = stateDragStartY state sody = state ^. mouse.dragStartY
sodxa = stateDragStartXAngle state sodxa = state ^. mouse.dragStartXAngle
sodya = stateDragStartYAngle state sodya = state ^. mouse.dragStartYAngle
x = stateCursorPosX state x' = state ^. mouse.mousePosition.x
y = stateCursorPosY state y' = state ^. mouse.mousePosition.y
let myrot = (x - sodx) / 2 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'
newXAngle' = sodxa + mxrot/100 newXAngle' = sodxa + mxrot/100
newYAngle newYAngle
@@ -254,25 +255,22 @@ run = do
| newYAngle' < (-pi) = newYAngle' + 2 * pi | newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle' | otherwise = newYAngle'
newYAngle' = sodya + myrot/100 newYAngle' = sodya + myrot/100
put $ state
{ stateXAngle = newXAngle modify $ ((camera.xAngle) .~ newXAngle)
, stateYAngle = newYAngle . ((camera.yAngle) .~ newYAngle)
}
-- 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 ->
let let
multc = cos $ stateYAngle s multc = cos $ state ^. camera.yAngle
mults = sin $ stateYAngle s mults = sin $ state ^. camera.yAngle
in modx x' = x' - 0.2 * kxrot * multc
s {
statePositionX = statePositionX s - 0.2 * kxrot * multc
- 0.2 * kyrot * mults - 0.2 * kyrot * mults
, statePositionY = statePositionY s + 0.2 * kxrot * mults mody y' = y' - 0.2 * kxrot * mults
- 0.2 * kyrot * multc - 0.2 * kyrot * multc
} modify $ (camera.camPosition.x %~ modx)
. (camera.camPosition.y %~ mody)
{- {-
--modify the state with all that happened in mt time. --modify the state with all that happened in mt time.
@@ -281,49 +279,45 @@ 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 (state ^. io.clock) -- get time-diffs
title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"] title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"]
setWindowTitle win title setWindowTitle (env ^. windowObject) 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
-- set state with new clock-time -- set state with new clock-time
modify $ \s -> s modify $ io.clock .~ mt
{ shouldClose <- return $ state ^. window.shouldClose
stateClock = mt
}
shouldClose <- return $ stateWinClose state
unless shouldClose run unless shouldClose run
getArrowMovement :: Pioneers (Int, Int) getArrowMovement :: Pioneers (Int, Int)
getArrowMovement = do getArrowMovement = do
state <- get state <- get
aks <- return $ stateArrowsPressed state aks <- return $ state ^. (keyboard.arrowsPressed)
let let
horz = left' + right' horz = left' + right'
vert = up'+down' vert = up'+down'
left' = if arrowLeft aks then -1 else 0 left' = if aks ^. left then -1 else 0
right' = if arrowRight aks then 1 else 0 right' = if aks ^. right then 1 else 0
up' = if arrowUp aks then -1 else 0 up' = if aks ^. up then -1 else 0
down' = if arrowDown aks then 1 else 0 down' = if aks ^. down then 1 else 0
return (horz,vert) return (horz,vert)
adjustWindow :: Pioneers () adjustWindow :: Pioneers ()
adjustWindow = do adjustWindow = do
state <- get state <- get
let fbWidth = stateWindowWidth state let fbWidth = state ^. window.width
fbHeight = stateWindowHeight state fbHeight = state ^. window.height
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
ratio = fromIntegral fbWidth / fromIntegral fbHeight ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio frust = createFrustum fov near far ratio
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight) liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
put $ state { modify $ camera.frustum .~ frust
stateFrustum = frust
}
processEvents :: Pioneers () processEvents :: Pioneers ()
@@ -337,18 +331,15 @@ processEvents = do
processEvent :: Event -> Pioneers () processEvent :: Event -> Pioneers ()
processEvent e = do processEvent e = do
return ()
case eventData e of case eventData e of
Window _ winEvent -> Window _ winEvent ->
case winEvent of case winEvent of
Closing -> Closing ->
modify $ \s -> s { modify $ window.shouldClose .~ True
stateWinClose = True
}
Resized {windowResizedTo=size} -> do Resized {windowResizedTo=size} -> do
modify $ \s -> s { modify $ (window.width .~ (sizeWidth size))
stateWindowWidth = sizeWidth size . (window.height .~ (sizeHeight size))
,stateWindowHeight = sizeHeight size
}
adjustWindow adjustWindow
SizeChanged -> SizeChanged ->
adjustWindow adjustWindow
@@ -357,78 +348,50 @@ processEvent e = do
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e] --liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
Keyboard movement _ isRepeated 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
let aks = keyboard.arrowsPressed in
case keyScancode key of case keyScancode key of
Escape -> Escape ->
modify $ \s -> s { modify $ window.shouldClose .~ True
stateWinClose = True
}
SDL.Left -> SDL.Left ->
modify $ \s -> s { modify $ aks.left .~ (movement == KeyDown)
stateArrowsPressed = (stateArrowsPressed s) {
arrowLeft = movement == KeyDown
}
}
SDL.Right -> SDL.Right ->
modify $ \s -> s { modify $ aks.right .~ (movement == KeyDown)
stateArrowsPressed = (stateArrowsPressed s) {
arrowRight = movement == KeyDown
}
}
SDL.Up -> SDL.Up ->
modify $ \s -> s { modify $ aks.up .~ (movement == KeyDown)
stateArrowsPressed = (stateArrowsPressed s) {
arrowUp = movement == KeyDown
}
}
SDL.Down -> SDL.Down ->
modify $ \s -> s { modify $ aks.down .~ (movement == KeyDown)
stateArrowsPressed = (stateArrowsPressed s) {
arrowDown = movement == KeyDown
}
}
SDL.KeypadPlus -> SDL.KeypadPlus ->
when (movement == KeyDown) $ do when (movement == KeyDown) $ do
modify $ \s -> s { modify $ (gl.glMap.stateTessellationFactor) %~ ((min 5) . (+1))
stateTessellationFactor = min (stateTessellationFactor s + 1) 5
}
state <- get state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state] liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
SDL.KeypadMinus -> SDL.KeypadMinus ->
when (movement == KeyDown) $ do when (movement == KeyDown) $ do
modify $ \s -> s { modify $ (gl.glMap.stateTessellationFactor) %~ ((max 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 $ state ^. gl.glMap.stateTessellationFactor]
_ -> _ ->
return () return ()
MouseMotion _ mouseId st (Position x y) xrel yrel -> do MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do
state <- get state <- get
when (stateMouseDown state && not (stateDragging state)) $ when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
put $ state modify $ (mouse.isDragging .~ True)
{ stateDragging = True . (mouse.dragStartX .~ (fromIntegral x))
, stateDragStartX = fromIntegral x . (mouse.dragStartY .~ (fromIntegral y))
, stateDragStartY = fromIntegral y . (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
, stateDragStartXAngle = stateXAngle state . (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
, stateDragStartYAngle = stateYAngle state
} modify $ (mouse.mousePosition. Types.x .~ (fromIntegral x))
modify $ \s -> s { . (mouse.mousePosition. Types.y .~ (fromIntegral y))
stateCursorPosX = fromIntegral x MouseButton _ mouseId button state (SDL.Position x y) ->
, stateCursorPosY = fromIntegral 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
modify $ \s -> s { modify $ mouse.isDown .~ pressed
stateMouseDown = pressed
}
unless pressed $ do unless pressed $ do
st <- get st <- get
if stateDragging st then if st ^. mouse.isDragging then
modify $ \s -> s { modify $ mouse.isDragging .~ False
stateDragging = False
}
else else
clickHandler (UI.Callbacks.Pixel x y) clickHandler (UI.Callbacks.Pixel x y)
RightButton -> do RightButton -> do
@@ -437,11 +400,9 @@ processEvent e = do
return () return ()
MouseWheel _ mouseId hscroll vscroll -> do MouseWheel _ mouseId hscroll vscroll -> do
env <- ask env <- ask
modify $ \s -> s state <- get
{ stateZDist = let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
let zDist' = stateZDist s + realToFrac (negate vscroll) modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
in curb (envZDistClosest env) (envZDistFarthest env) zDist' Quit -> modify $ window.shouldClose .~ 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]

16
src/Types.hs
View File

@@ -101,8 +101,18 @@ data State = State
, _game :: !GameState , _game :: !GameState
} }
$(mkLabels [''State, ''GLState, ''GLMapState, ''KeyboardState, ''ArrowKeyState, $(makeLenses ''State)
''MouseState, ''GameState, ''IOState, ''CameraState, ''WindowState, $(makeLenses ''GLState)
''Position, ''Env]) $(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 type Pioneers = RWST Env () State IO