From 1126cfc25af9e74d0f8abe8a55a70bcb3821691d Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Wed, 5 Feb 2014 16:33:32 +0100 Subject: [PATCH] moved types to types - moved types to types - added callback - included sdl-ttf --- Pioneers.cabal | 7 +++-- deps/getDeps.sh | 11 ++++++- src/Main.hs | 84 +++++++++++++------------------------------------ 3 files changed, 36 insertions(+), 66 deletions(-) diff --git a/Pioneers.cabal b/Pioneers.cabal index 338f404..f49b250 100644 --- a/Pioneers.cabal +++ b/Pioneers.cabal @@ -11,7 +11,9 @@ executable Pioneers 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 a872a91..b0445db 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BangPatterns, DoAndIfThenElse #-} module Main where -- Monad-foo and higher functional stuff @@ -25,6 +25,8 @@ 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 @@ -39,66 +41,11 @@ import Render.Misc (checkError, 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 @@ -108,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 @@ -121,6 +69,9 @@ 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 @@ -141,6 +92,7 @@ main = do , envWindow = window , envZDistClosest = zDistClosest , envZDistFarthest = zDistFarthest + , envFont = font } state = State { stateWindowWidth = fbWidth @@ -449,10 +401,16 @@ processEvent e = do modify $ \s -> s { stateMouseDown = pressed } - unless pressed $ - modify $ \s -> s { - stateDragging = False - } + 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