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. -- .hs or .lhs file containing the Main module.
main-is: Main.hs main-is: Main.hs
ghc-options: -Wall ghc-options: -Wall
extra-libraries: GLEW
-- Modules included in this executable, other than Main. -- Modules included in this executable, other than Main.
other-modules: Types other-modules: Types
@ -69,8 +70,9 @@ executable haskelloids
, sdl2 >= 2.1.3.1 , sdl2 >= 2.1.3.1
, containers , containers
, random , random
, nanovg
, linear , linear
, stm
, nanovg
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: src hs-source-dirs: src

View file

@ -59,3 +59,9 @@ updateHaskelloid sec has =
{ hPos = hPos has + hVel has * V2 sec sec { hPos = hPos has + hVel has * V2 sec sec
, hRot = hRot has + hPitch has * 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 module Init where
import Affection as A import Affection as A
@ -10,26 +11,39 @@ import Data.Maybe
import Control.Monad (when) import Control.Monad (when)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import System.Random import System.Random
import System.Exit (exitFailure)
import NanoVG hiding (V2(..))
import Linear import Linear
import NanoVG hiding (V2)
import Foreign.C.Types (CInt(..))
-- Internal imports -- Internal imports
import Types import Types
foreign import ccall unsafe "glewInit"
glewInit :: IO CInt
load :: IO UserData load :: IO UserData
load = do load = do
liftIO $ logIO A.Debug "init GLEW"
_ <- glewInit
liftIO $ logIO A.Debug "loading state" liftIO $ logIO A.Debug "loading state"
liftIO $ logIO A.Debug "creating NanoVG context" liftIO $ logIO A.Debug "create context"
nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes]) nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug])
liftIO $ logIO A.Debug "load ship image" liftIO $ logIO A.Debug "load ship image"
mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0 mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0
when (isNothing mshipImage) $ when (isNothing mshipImage) $ do
logIO Error "Failed loading image assets" logIO Error "Failed loading image assets"
exitFailure
subs <- Subsystems
<$> (return . Window =<< newTVarIO [])
<*> (return . Keyboard =<< newTVarIO [])
return UserData return UserData
{ ship = Ship { ship = Ship
{ sPos = V2 400 300 { sPos = V2 400 300
@ -42,6 +56,7 @@ load = do
, state = Menu , state = Menu
, fade = FadeIn 1 , fade = FadeIn 1
, nano = nvgCtx , nano = nvgCtx
, subsystems = subs
} }

View file

@ -1,7 +1,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Affection import Affection as A
import SDL (($=)) import SDL (($=))
import qualified SDL import qualified SDL
@ -9,6 +9,10 @@ import qualified Data.Map as M
import Linear as L import Linear as L
import NanoVG
import Control.Monad.IO.Class (liftIO)
-- internal imports -- internal imports
import Types import Types
@ -18,7 +22,7 @@ import Init
main :: IO () main :: IO ()
main = do main = do
logIO Debug "Starting" logIO A.Debug "Starting"
withAffection AffectionConfig withAffection AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Haskelloids" , windowTitle = "Haskelloids"
@ -49,7 +53,10 @@ handle e = do
draw :: Affection UserData () draw :: Affection UserData ()
draw = do 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) -- GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
-- ud <- getAffection -- ud <- getAffection
-- GL.currentProgram $= (Just . GLU.program $ program sd) -- 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 qualified Data.Map as M
import NanoVG import NanoVG hiding (V2(..))
import Linear
import Foreign.C.Types
-- internal imports -- internal imports
@ -20,23 +24,10 @@ import Types
import Commons import Commons
handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData () handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData ()
handleMenuEvent loader es = handleMenuEvent _ es = do
mapM_ (\e -> (Subsystems w k) <- subsystems <$> getAffection
case e of _ <- consumeSDLEvents w =<< consumeSDLEvents k es
SDL.KeyboardEvent dat -> return ()
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
loadMenu :: Affection UserData () loadMenu :: Affection UserData ()
loadMenu = do loadMenu = do
@ -47,6 +38,17 @@ loadMenu = do
when (isNothing mhaskImage) $ when (isNothing mhaskImage) $
liftIO $ logIO Error "Failed to load asset haskelloid" liftIO $ logIO Error "Failed to load asset haskelloid"
hs <- newHaskelloids (fromJust mhaskImage) 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 putAffection ud
{ haskelloids = hs { haskelloids = hs
, fade = FadeIn 1 , fade = FadeIn 1
@ -70,3 +72,41 @@ updateMenu sec = do
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1 { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs , 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 -- smEvent InGame = handleGameEvent
smDraw Menu = return () smDraw Menu = drawMenu
-- smDraw InGame = drawGame -- smDraw InGame = drawGame

View file

@ -7,6 +7,9 @@ import qualified SDL
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import Linear import Linear
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData data UserData = UserData
{ ship :: Ship { ship :: Ship
, haskelloids :: [Haskelloid] , haskelloids :: [Haskelloid]
@ -17,6 +20,7 @@ data UserData = UserData
, state :: State , state :: State
, fade :: MenuFade , fade :: MenuFade
, nano :: Context , nano :: Context
, subsystems :: Subsystems
} }
data Ship = Ship data Ship = Ship
@ -48,3 +52,43 @@ data WonLost
= Won = Won
| Lost | Lost
deriving (Eq) 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