diff --git a/assets/haskelloid.png b/assets/haskelloid.png new file mode 100644 index 0000000..f75a4e7 Binary files /dev/null and b/assets/haskelloid.png differ diff --git a/haskelloids.cabal b/haskelloids.cabal index 8586a48..a1be398 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -51,6 +51,7 @@ executable haskelloids -- .hs or .lhs file containing the Main module. main-is: Main.hs ghc-options: -Wall + extra-libraries: GLEW -- Modules included in this executable, other than Main. other-modules: Types @@ -69,8 +70,9 @@ executable haskelloids , sdl2 >= 2.1.3.1 , containers , random - , nanovg , linear + , stm + , nanovg -- Directories containing source files. hs-source-dirs: src diff --git a/src/Commons.hs b/src/Commons.hs index ff60770..8544682 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -59,3 +59,9 @@ updateHaskelloid sec has = { hPos = hPos has + hVel has * V2 sec sec , hRot = hRot has + hPitch has * sec } + +clamp :: Ord a => a -> a -> a -> a +clamp a' low up + | a' < low = low + | a' > up = up + | otherwise = a' diff --git a/src/Init.hs b/src/Init.hs index d3cd264..8f8b200 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} module Init where import Affection as A @@ -10,26 +11,39 @@ import Data.Maybe import Control.Monad (when) import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM import System.Random - -import NanoVG hiding (V2(..)) +import System.Exit (exitFailure) import Linear +import NanoVG hiding (V2) + +import Foreign.C.Types (CInt(..)) + -- Internal imports import Types +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + load :: IO UserData load = do + liftIO $ logIO A.Debug "init GLEW" + _ <- glewInit liftIO $ logIO A.Debug "loading state" - liftIO $ logIO A.Debug "creating NanoVG context" - nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes]) + liftIO $ logIO A.Debug "create context" + nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) liftIO $ logIO A.Debug "load ship image" - mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0 - when (isNothing mshipImage) $ + mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0 + when (isNothing mshipImage) $ do logIO Error "Failed loading image assets" + exitFailure + subs <- Subsystems + <$> (return . Window =<< newTVarIO []) + <*> (return . Keyboard =<< newTVarIO []) return UserData { ship = Ship { sPos = V2 400 300 @@ -42,6 +56,7 @@ load = do , state = Menu , fade = FadeIn 1 , nano = nvgCtx + , subsystems = subs } diff --git a/src/Main.hs b/src/Main.hs index c132847..d206e91 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Main where -import Affection +import Affection as A import SDL (($=)) import qualified SDL @@ -9,6 +9,10 @@ import qualified Data.Map as M import Linear as L +import NanoVG + +import Control.Monad.IO.Class (liftIO) + -- internal imports import Types @@ -18,7 +22,7 @@ import Init main :: IO () main = do - logIO Debug "Starting" + logIO A.Debug "Starting" withAffection AffectionConfig { initComponents = All , windowTitle = "Haskelloids" @@ -49,7 +53,10 @@ handle e = do draw :: Affection UserData () draw = do - return () + ud <- getAffection + liftIO $ beginFrame (nano ud) 800 600 (800/600) + smDraw (state ud) + liftIO $ endFrame (nano ud) -- GL.viewport $= (GL.Position 0 0, GL.Size 800 600) -- ud <- getAffection -- GL.currentProgram $= (Just . GLU.program $ program sd) diff --git a/src/Menu.hs b/src/Menu.hs index 389ee59..1976332 100644 --- a/src/Menu.hs +++ b/src/Menu.hs @@ -12,7 +12,11 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Map as M -import NanoVG +import NanoVG hiding (V2(..)) + +import Linear + +import Foreign.C.Types -- internal imports @@ -20,23 +24,10 @@ import Types import Commons handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData () -handleMenuEvent loader es = - mapM_ (\e -> - case e of - SDL.KeyboardEvent dat -> - case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of - SDL.KeycodeSpace -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do - ud <- getAffection - loader - _ -> return () - SDL.WindowClosedEvent _ -> do - ad <- get - put ad - { quitEvent = True - } - _ -> return () - ) es +handleMenuEvent _ es = do + (Subsystems w k) <- subsystems <$> getAffection + _ <- consumeSDLEvents w =<< consumeSDLEvents k es + return () loadMenu :: Affection UserData () loadMenu = do @@ -47,6 +38,17 @@ loadMenu = do when (isNothing mhaskImage) $ liftIO $ logIO Error "Failed to load asset haskelloid" hs <- newHaskelloids (fromJust mhaskImage) + _ <- partSubscribe (subKeyboard $ subsystems ud) + (\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "seeya" + quit + SDL.KeycodeF -> do + when (msgKbdKeyMotion kbdev == SDL.Pressed) $ do + liftIO $ logIO A.Debug "screen toggling" + toggleScreen + _ -> return () + ) putAffection ud { haskelloids = hs , fade = FadeIn 1 @@ -70,3 +72,41 @@ updateMenu sec = do { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1 , haskelloids = nhs } + +drawMenu :: Affection UserData () +drawMenu = do + ud <- getAffection + let V2 sx sy = fmap (CFloat . realToFrac) (sPos $ ship ud) + liftIO $ do + save (nano ud) + sPaint <- imagePattern (nano ud) 400 300 20 20 0 (sImg $ ship ud) 255 + beginPath (nano ud) + rect (nano ud) 400 300 20 20 + fillPaint (nano ud) sPaint + fill (nano ud) + restore (nano ud) + dt <- getElapsedTime + liftIO $ + drawSpinner (nano ud) 100 100 100 (CFloat $ realToFrac dt) + +drawSpinner :: Context -> CFloat -> CFloat -> CFloat -> CFloat -> IO () +drawSpinner vg cx cy r t = do + let a0 = 0+t*6 + a1 = pi + t*6 + r0 = r + r1 = r*0.75 + save vg + + beginPath vg + arc vg cx cy r0 a0 a1 CW + arc vg cx cy r1 a1 a0 CCW + closePath vg + let ax = cx+cos a0 * (r0+r1)*0.5 + ay = cy+sin a0 * (r0+r1)*0.5 + bx = cx+cos a1 * (r0+r1)*0.5 + by = cy+sin a1 * (r0+r1)*0.5 + paint <- linearGradient vg ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128) + fillPaint vg paint + fill vg + + restore vg diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 5aad6ca..920489a 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -30,6 +30,6 @@ instance StateMachine State UserData where -- smEvent InGame = handleGameEvent - smDraw Menu = return () + smDraw Menu = drawMenu -- smDraw InGame = drawGame diff --git a/src/Types.hs b/src/Types.hs index 3c72a58..11ba3ae 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -7,6 +7,9 @@ import qualified SDL import NanoVG hiding (V2(..)) import Linear +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) + data UserData = UserData { ship :: Ship , haskelloids :: [Haskelloid] @@ -17,6 +20,7 @@ data UserData = UserData , state :: State , fade :: MenuFade , nano :: Context + , subsystems :: Subsystems } data Ship = Ship @@ -48,3 +52,43 @@ data WonLost = Won | Lost deriving (Eq) + +data Subsystems = Subsystems + { subWindow :: Window + , subKeyboard :: Keyboard + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) + +instance Participant Window WindowMessage UserData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) = generalSubscribe t + + partUnSubscribe (Window t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Window UserData where + consumeSDLEvents = consumeSDLWindowEvents + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) + +instance Participant Keyboard KeyboardMessage UserData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) = generalSubscribe t + + partUnSubscribe (Keyboard t) uuid = + liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid)) + +instance SDLSubsystem Keyboard UserData where + consumeSDLEvents = consumeSDLKeyboardEvents + +generalSubscribe t funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return uuid