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

Merge branch 'tessallation' of pwning.de:pioneers into tessallation

Browse Source
This commit is contained in:
tpajenka
2014-02-07 17:08:23 +01:00
parent 47e49660cf 95a7a5b9f1
commit a7861e9f7b
5 changed files with 236 additions and 160 deletions
Download Patch File Download Diff File Expand all files Collapse all files

9
Pioneers.cabal
View File

@@ -6,12 +6,14 @@ author: sdressel
executable Pioneers executable Pioneers
hs-source-dirs: src hs-source-dirs: src
ghc-options: -Wall ghc-options: -Wall -Odph -rtsopts -threaded -fno-liberate-case -funfolding-use-threshold1000 -funfolding-keeness-factor1000 -optlo-O3 -fllvm
other-modules: other-modules:
Map.Map, Map.Map,
Render.Misc, Render.Misc,
Render.Render, Render.Render,
Render.RenderObject Render.RenderObject,
UI.Callbacks,
Types
main-is: Main.hs main-is: Main.hs
build-depends: build-depends:
base >=4.6, base >=4.6,
@@ -29,5 +31,6 @@ executable Pioneers
linear >=1.3.1 && <1.4, linear >=1.3.1 && <1.4,
lens >=3.10.1 && <3.11, lens >=3.10.1 && <3.11,
SDL2 >= 0.1.0, SDL2 >= 0.1.0,
time >=1.4.0 && <1.5 time >=1.4.0 && <1.5,
SDL2-ttf >=0.1.0 && <0.2

11
deps/getDeps.sh vendored
View File

@@ -63,6 +63,15 @@ else
cd .. cd ..
fi fi
if [ ! -d "hsSDL2-ttf" ]
then
git clone https://github.com/osa1/hsSDL2-ttf hsSDL2-ttf
else
cd hsSDL2-ttf
git pull
cd ..
fi
echo "trying to build" echo "trying to build"
cabal install haddock cabal install haddock
@@ -79,7 +88,7 @@ do
cabal configure cabal configure
cabal build cabal build
cabal haddock --hyperlink-source cabal haddock --hyperlink-source
cabal install cabal install --force-reinstalls
cd .. cd ..
fi fi
done done

285
src/Main.hs
View File

@@ -1,19 +1,15 @@
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
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,11 +20,13 @@ 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
import Graphics.UI.SDL as SDL import Graphics.UI.SDL as SDL
import Graphics.UI.SDL.TTF as TTF
import Graphics.UI.SDL.TTF.Types
-- Render -- Render
import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GL as GL
@@ -40,69 +38,14 @@ 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)
import UI.Callbacks
import Types
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
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
, shdrTessInnerIndex :: !GL.UniformLocation
, shdrTessOuterIndex :: !GL.UniformLocation
, stateTessellationFactor :: !Int
--- the map
, stateMap :: !GL.BufferObject
, mapVert :: !GL.NumArrayIndices
}
type Pioneers = RWST Env () State IO
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
main = do main = do
@@ -112,9 +55,10 @@ main = do
,WindowResizable -- and resizable ,WindowResizable -- and resizable
,WindowInputFocus -- focused (=> active) ,WindowInputFocus -- focused (=> active)
,WindowMouseFocus -- Mouse into it ,WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse) ,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window -> do ] $ \window -> do
withOpenGL window $ do withOpenGL window $ do
TTF.withInit $ do
(Size fbWidth fbHeight) <- glGetDrawableSize window (Size fbWidth fbHeight) <- glGetDrawableSize window
initRendering initRendering
--generate map vertices --generate map vertices
@@ -125,9 +69,13 @@ main = do
putStrLn "foo" putStrLn "foo"
now <- getCurrentTime now <- getCurrentTime
putStrLn "foo" putStrLn "foo"
font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
TTF.setFontStyle font TTFNormal
TTF.setFontHinting font TTFHNormal
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
@@ -144,6 +92,7 @@ main = do
, envWindow = window , envWindow = window
, envZDistClosest = zDistClosest , envZDistClosest = zDistClosest
, envZDistFarthest = zDistFarthest , envZDistFarthest = zDistFarthest
, envFont = font
} }
state = State state = State
{ stateWindowWidth = fbWidth { stateWindowWidth = fbWidth
@@ -188,7 +137,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 +160,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 +208,7 @@ run = do
-- draw Scene -- draw Scene
draw draw
liftIO $ do liftIO $ glSwapWindow win
glSwapWindow win
-- getEvents & process -- getEvents & process
processEvents processEvents
@@ -292,7 +239,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 +262,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
@@ -369,84 +316,110 @@ processEvents = do
processEvent :: Event -> Pioneers () processEvent :: Event -> Pioneers ()
processEvent e = do processEvent e = do
case eventData e of case eventData e of
Window _ winEvent -> Window _ winEvent ->
case winEvent of case winEvent of
Closing -> modify $ \s -> s { Closing ->
stateWinClose = True 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
}
}
SDL.KeypadPlus -> when (movement == KeyDown) $ do
modify $ \s -> s {
stateTessellationFactor = min ((stateTessellationFactor s)+1) 5
}
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
SDL.KeypadMinus -> when (movement == KeyDown) $ do
modify $ \s -> s {
stateTessellationFactor = max ((stateTessellationFactor s)-1) 1
}
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
_ -> 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
} }
Resized {windowResizedTo=size} -> do
modify $ \s -> s {
stateWindowWidth = sizeWidth size
,stateWindowHeight = 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
case keyScancode key of
Escape ->
modify $ \s -> s { modify $ \s -> s {
stateCursorPosX = fromIntegral x stateWinClose = True
, stateCursorPosY = fromIntegral y
} }
MouseButton _ id button state (Position x y) -> SDL.Left ->
case button of modify $ \s -> s {
LeftButton -> do stateArrowsPressed = (stateArrowsPressed s) {
let pressed = state == Pressed arrowLeft = movement == KeyDown
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} SDL.Right ->
-- there is more (joystic, touchInterface, ...), but currently ignored modify $ \s -> s {
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:",(show e)] 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
}
}
SDL.KeypadPlus ->
when (movement == KeyDown) $ do
modify $ \s -> s {
stateTessellationFactor = min (stateTessellationFactor s + 1) 5
}
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
SDL.KeypadMinus ->
when (movement == KeyDown) $ do
modify $ \s -> s {
stateTessellationFactor = max (stateTessellationFactor s - 1) 1
}
state <- get
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ stateTessellationFactor state]
_ ->
return ()
MouseMotion _ mouseId 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 _ mouseId button state (Position x y) ->
case button of
LeftButton -> do
let pressed = state == Pressed
modify $ \s -> s {
stateMouseDown = pressed
}
unless pressed $ do
st <- get
if stateDragging st then
modify $ \s -> s {
stateDragging = 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
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
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]

71
src/Types.hs Normal file
View File

@@ -0,0 +1,71 @@
module Types where
import Control.Concurrent.STM (TQueue)
import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL
import Foreign.C (CFloat)
import Data.Time (UTCTime)
import Linear.Matrix (M44)
import Control.Monad.RWS.Strict (RWST)
import Graphics.UI.SDL.TTF.Types as TTF
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
, envFont :: TTF.TTFFont
}
--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
, shdrTessInnerIndex :: !GL.UniformLocation
, shdrTessOuterIndex :: !GL.UniformLocation
, stateTessellationFactor :: !Int
--- the map
, stateMap :: !GL.BufferObject
, mapVert :: !GL.NumArrayIndices
}
type Pioneers = RWST Env () State IO

20
src/UI/Callbacks.hs Normal file
View 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?