menu looks good

This commit is contained in:
nek0 2017-12-19 17:30:44 +01:00
parent bc8cf3cd8c
commit 27179fd225
6 changed files with 46 additions and 17 deletions

View file

@ -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))

View file

@ -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
}

View file

@ -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

View file

@ -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

View file

@ -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 ()

View file

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