diff --git a/Pioneers.cabal b/Pioneers.cabal index e12f96b..f49b250 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -6,12 +6,14 @@ author: sdressel executable Pioneers 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: Map.Map, Render.Misc, Render.Render, - Render.RenderObject + Render.RenderObject, + UI.Callbacks, + Types main-is: Main.hs build-depends: base >=4.6, @@ -29,5 +31,6 @@ executable Pioneers linear >=1.3.1 && <1.4, lens >=3.10.1 && <3.11, SDL2 >= 0.1.0, - time >=1.4.0 && <1.5 + time >=1.4.0 && <1.5, + SDL2-ttf >=0.1.0 && <0.2 diff --git a/deps/getDeps.sh b/deps/getDeps.sh index 4514f31..5c3ccad 100755 --- a/deps/getDeps.sh +++ b/deps/getDeps.sh @@ -63,6 +63,15 @@ else cd .. 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" cabal install haddock @@ -79,7 +88,7 @@ do cabal configure cabal build cabal haddock --hyperlink-source - cabal install + cabal install --force-reinstalls cd .. fi done diff --git a/src/Main.hs b/src/Main.hs index c6bdfef..3a26626 100644 --- a/src/Main.hs +++ b/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,11 +20,13 @@ import Foreign (Ptr, castPtr, with) import Foreign.C (CFloat) -- Math -import Control.Lens (transposeOf, (^.)) +import Control.Lens ((^.)) import Linear as L -- GUI 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 @@ -40,69 +38,14 @@ import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader import Map.Map 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 - , 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 = do @@ -112,9 +55,10 @@ main = do ,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 @@ -125,9 +69,13 @@ main = do 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 = 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 @@ -144,6 +92,7 @@ main = do , envWindow = window , envZDistClosest = zDistClosest , envZDistFarthest = zDistFarthest + , envFont = font } state = State { stateWindowWidth = fbWidth @@ -188,7 +137,6 @@ main = do draw :: Pioneers () draw = do - env <- ask state <- get let xa = stateXAngle state ya = stateYAngle state @@ -212,23 +160,23 @@ draw = do 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 -> + 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" @@ -260,8 +208,7 @@ run = do -- draw Scene draw - liftIO $ do - glSwapWindow win + liftIO $ glSwapWindow win -- getEvents & process processEvents @@ -292,7 +239,7 @@ run = do -- get cursor-keys - if pressed --TODO: Add sin/cos from stateYAngle - (kxrot, kyrot) <- fmap ((join (***)) fromIntegral) getArrowMovement + (kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement modify $ \s -> let multc = cos $ stateYAngle s @@ -315,8 +262,8 @@ run = do mt <- liftIO $ do now <- getCurrentTime diff <- return $ diffUTCTime now (stateClock state) -- get time-diffs - title <- return $ unwords ["Pioneers @ ",show $ ((round .fromRational.toRational $ 1/diff)::Int),"fps"] - setWindowTitle win $ title + title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"] + setWindowTitle win title sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds threadDelay sleepAmount return now @@ -369,84 +316,110 @@ processEvents = do processEvent :: Event -> Pioneers () processEvent e = do 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 - } - } - 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 + Window _ winEvent -> + case winEvent of + Closing -> + modify $ \s -> s { + stateWinClose = True } + 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 { - stateCursorPosX = fromIntegral x - , stateCursorPosY = fromIntegral y + stateWinClose = True } - 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' + SDL.Left -> + modify $ \s -> s { + stateArrowsPressed = (stateArrowsPressed s) { + arrowLeft = movement == KeyDown + } } - Quit -> modify $ \s -> s {stateWinClose = True} - -- there is more (joystic, touchInterface, ...), but currently ignored - _ -> liftIO $ putStrLn $ unwords ["Not processing Event:",(show e)] \ No newline at end of file + 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 _ 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] diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..c896bba --- /dev/null +++ b/src/Types.hs @@ -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 \ No newline at end of file diff --git a/src/UI/Callbacks.hs b/src/UI/Callbacks.hs new file mode 100644 index 0000000..b4daff3 --- /dev/null +++ b/src/UI/Callbacks.hs @@ -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?