make it work with nanovg

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

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'

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
     }
 
 

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)

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

src/StateMachine.hs

@@ -30,6 +30,6 @@ instance StateMachine State UserData where
 
   -- smEvent InGame = handleGameEvent
 
-  smDraw Menu = return ()
+  smDraw Menu = drawMenu
 
   -- smDraw InGame = drawGame

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