make it work with nanovg

This commit is contained in:
nek0 2017-12-19 06:49:41 +01:00
parent e82c826063
commit 990f1a7daf
8 changed files with 143 additions and 29 deletions

BIN
assets/haskelloid.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 44 KiB

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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