menu looks good

src/Commons.hs

@@ -25,17 +25,18 @@ import Types
 toR :: Double -> Double
 toR deg = deg * pi / 180
 
-wrapAround :: (Ord t, Num t) => V2 t -> t -> V2 t
+wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
 wrapAround (V2 nx ny) width = (V2 nnx nny)
   where
     nnx
-      | nx > 800    = nx - (800 + width)
-      | nx < -width = nx + 800 + width
+      | nx > 800 + half = nx - (800 + width)
+      | nx < -half      = nx + 800 + width
       | otherwise       = nx
     nny
-      | ny > 600    = ny - (600 + width)
-      | ny < -width = ny + 600 + width
+      | ny > 600 + half = ny - (600 + width)
+      | ny < -half      = ny + 600 + width
       | otherwise       = ny
+    half = width / 2
 
 newHaskelloids :: Image -> Affection UserData [Haskelloid]
 newHaskelloids img = liftIO $ mapM (\_ -> do
@@ -58,7 +59,9 @@ newHaskelloids img = liftIO $ mapM (\_ -> do
 updateHaskelloid :: Double -> Haskelloid -> Haskelloid
 updateHaskelloid dsec has =
   has
-    { hPos = wrapAround (hPos has + hVel has * V2 sec sec) (100 / fromIntegral (hDiv has))
+    { hPos = wrapAround
+      (hPos has + hVel has * V2 sec sec)
+      (100 / fromIntegral (hDiv has))
     , hRot = hRot has + hPitch has * sec
     }
   where
@@ -75,8 +78,9 @@ drawImage ctx img pos dim rot alpha = do
   let (V2 x y) = fmap CFloat pos
       (V2 w h) = fmap CFloat dim
   save ctx
-  translate ctx x y
+  translate ctx (x + (w/2)) (y + (h/2))
   rotate ctx (degToRad $ CFloat rot)
+  translate ctx (-(w/2)) (-(h/2))
   sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha)
   beginPath ctx
   rect ctx 0 0 w h
@@ -111,4 +115,6 @@ drawSpinner ctx x y cr ct = do
 drawHaskelloid :: Haskelloid -> Affection UserData ()
 drawHaskelloid (Haskelloid pos _ rot _ div img) = do
   ctx <- nano <$> getAffection
-  liftIO $ drawImage ctx img pos (fmap (/ fromIntegral div) (V2 100 100)) rot 255
+  liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
+  where
+    dim = (fmap (/ fromIntegral div) (V2 100 100))

src/Init.hs

@@ -41,6 +41,11 @@ load = do
   when (isNothing mshipImage) $ do
     logIO Error "Failed loading image assets"
     exitFailure
+  mfont <- createFont nvgCtx "modulo" (FileName "assets/Modulo.ttf")
+  when (isNothing mfont) $ do
+    logIO Error "Failed to load font"
+    exitFailure
+  liftIO $ logIO A.Debug "Initializing subsystems"
   subs <- Subsystems
     <$> (return . Window =<< newTVarIO [])
     <*> (return . Keyboard =<< newTVarIO [])
@@ -56,6 +61,7 @@ load = do
     , state = Menu
     , fade = FadeIn 1
     , nano = nvgCtx
+    , font = fromJust mfont
     , subsystems = subs
     }
 

src/Main.hs

@@ -48,8 +48,9 @@ update sec = do
 
 handle :: [SDL.EventPayload] -> Affection UserData ()
 handle e = do
-  ud <- getAffection
-  smEvent (state ud) e
+  (Subsystems w k) <- subsystems <$> getAffection
+  _ <- consumeSDLEvents w =<< consumeSDLEvents k e
+  return ()
 
 draw :: Affection UserData ()
 draw = do

src/Menu.hs

@@ -6,13 +6,14 @@ import qualified SDL
 import Debug.Trace
 
 import Data.Maybe
+import qualified Data.Set as S
 
 import Control.Monad (when)
 import Control.Monad.IO.Class (liftIO)
 
 import qualified Data.Map as M
 
-import NanoVG hiding (V2(..))
+import NanoVG hiding (V2(..), V4(..))
 
 import Linear
 
@@ -77,5 +78,21 @@ drawMenu :: Affection UserData ()
 drawMenu = do
   ud <- getAffection
   mapM_ drawHaskelloid (haskelloids ud)
+  liftIO $ do
+    let ctx = nano ud
+        alpha fio = case fio of
+          FadeIn d  -> (floor (255 * (1 - d)))
+          FadeOut d -> (floor (255 * d))
+    save ctx
+    fontSize ctx 120
+    fontFace ctx "modulo"
+    textAlign ctx (S.fromList [AlignCenter,AlignTop])
+    -- (Bounds (V4 b0 b1 b2 b3)) <- textBoxBounds ctx x y' 150 "HASKELLOIDS"
+    fillColor ctx (rgba 255 255 255 255)
+    textBox ctx 0 200 800 "HASKELLOIDS"
+    fillColor ctx (rgba 255 128 0 (alpha $ fade ud))
+    fontSize ctx 40
+    textBox ctx 0 350 800 "Press [Space] to PLay\nPress [Esc] to exit"
+    restore ctx
   -- t <- getElapsedTime
   -- liftIO $ drawSpinner (nano ud) 100 100 100 t

src/StateMachine.hs

@@ -26,10 +26,8 @@ instance StateMachine State UserData where
 
   -- smUpdate InGame sec = updateGame sec
 
-  smEvent Menu = handleMenuEvent (return ()) -- (smLoad InGame)
-
-  -- smEvent InGame = handleGameEvent
-
   smDraw Menu = drawMenu
 
   -- smDraw InGame = drawGame
+
+  smEvent _ _ = return ()

src/Types.hs

@@ -20,6 +20,7 @@ data UserData = UserData
   , state :: State
   , fade :: MenuFade
   , nano :: Context
+  , font :: Font
   , subsystems :: Subsystems
   }