making rewrite

This commit is contained in:
nek0 2017-12-16 19:06:36 +01:00
parent 31fd771e64
commit ca52ea7752
9 changed files with 111 additions and 94 deletions

2
.gitignore vendored
View file

@ -1,6 +1,8 @@
.cabal-sandbox/ .cabal-sandbox/
cabal.sandbox.config cabal.sandbox.config
dist/ dist/
*.prof
*.aux *.aux
*.hp *.hp
*.ps *.ps
*.swp

1
cabal.config Normal file
View file

@ -0,0 +1 @@
constraints: affection +debug

View file

@ -53,12 +53,13 @@ executable haskelloids
ghc-options: -Wall ghc-options: -Wall
-- Modules included in this executable, other than Main. -- Modules included in this executable, other than Main.
other-modules: InGame other-modules: Types
, Types
, Commons , Commons
, StateMachine , StateMachine
, Menu , Menu
, Init
default-extensions: OverloadedStrings
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: -- other-extensions:

View file

@ -4,18 +4,19 @@ module Commons where
import Affection import Affection
import qualified SDL import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M import qualified Data.Map as M
import Data.List (delete) import Data.List (delete)
import Data.Maybe (catMaybes, isJust) import Data.Maybe (catMaybes, isJust)
import Control.Monad (foldM, unless, when) import Control.Monad (foldM, unless, when)
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO) import System.Random (randomRIO)
import Debug.Trace import NanoVG hiding (V2(..))
import Linear
import Types import Types
@ -33,3 +34,28 @@ wrapAround (nx, ny) width = (nnx, nny)
| ny > 600 = ny - (600 + width) | ny > 600 = ny - (600 + width)
| ny < -width = ny + 600 + width | ny < -width = ny + 600 + width
| otherwise = ny | otherwise = ny
newHaskelloids :: Image -> Affection UserData [Haskelloid]
newHaskelloids img = liftIO $ mapM (\_ -> do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (0, 2*pi)
pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2)
return $ Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
div
img
) [1..10]
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
updateHaskelloid sec has =
has
{ hPos = hPos has + hVel has * V2 sec sec
, hRot = hRot has + hPitch has * sec
}

View file

@ -1,6 +1,6 @@
module Init where module Init where
import Affection import Affection as A
import SDL (($=)) import SDL (($=))
import qualified SDL import qualified SDL
@ -8,9 +8,14 @@ import qualified SDL
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe import Data.Maybe
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import System.Random import System.Random
import NanoVG import NanoVG hiding (V2(..))
import Linear
-- Internal imports -- Internal imports
@ -18,33 +23,19 @@ import Types
load :: IO UserData load :: IO UserData
load = do load = do
liftIO $ logIO A.Debug "loading state"
liftIO $ logIO A.Debug "creating NanoVG context"
nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes]) nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
mhaskImage <- createImage nvgCtx "assets/haskelloid.svg" 0 liftIO $ logIO A.Debug "load ship image"
mshipImage <- createImage nvgCtx "assets/ship.svg" 0 mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0
when (isNothing mhasImage || isNothing mshipImage) $ when (isNothing mshipImage) $
logIO Error "Failed loading image assets" logIO Error "Failed loading image assets"
hasks <- mapM (\_ -> do
posx <- randomRIO (0, 800)
posy <- randomRIO (0, 600)
velx <- randomRIO (-10, 10)
vely <- randomRIO (-10, 10)
rot <- randomRIO (0, 2*pi)
pitch <- randomRIO (-pi, pi)
div <- randomRIO (1, 2)
return Haskelloid
(V2 posx posy)
(V2 velx vely)
rot
pitch
div
(fromJust mhaskImage)
) [1..10]
return UserData return UserData
{ ship = Ship { ship = Ship
{ sPos = V2 400 300 { sPos = V2 400 300
, sVel = V2 0 0 , sVel = V2 0 0
, sRot = 0 , sRot = 0
, sImg = fromust mshipImage , sImg = fromJust mshipImage
} }
, haskelloids = [] , haskelloids = []
, wonlost = Nothing , wonlost = Nothing

View file

@ -5,9 +5,6 @@ import Affection
import SDL (($=)) import SDL (($=))
import qualified SDL import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
import qualified Data.Map as M import qualified Data.Map as M
import Linear as L import Linear as L
@ -25,7 +22,7 @@ main = do
withAffection AffectionConfig withAffection AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Haskelloids" , windowTitle = "Haskelloids"
, windowConfig = defaultWindow , windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL { SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3 { SDL.glProfile = SDL.Core SDL.Normal 3 3
} }
@ -37,7 +34,7 @@ main = do
, eventLoop = handle , eventLoop = handle
, updateLoop = update , updateLoop = update
, drawLoop = draw , drawLoop = draw
, cleanUp = clean , cleanUp = (\_ -> return ())
} }
update :: Double -> Affection UserData () update :: Double -> Affection UserData ()
@ -45,19 +42,20 @@ update sec = do
ud <- getAffection ud <- getAffection
smUpdate (state ud) sec smUpdate (state ud) sec
handle :: SDL.EventPayload -> Affection UserData () handle :: [SDL.EventPayload] -> Affection UserData ()
handle e = do handle e = do
ud <- getAffection ud <- getAffection
smEvent (state ud) e smEvent (state ud) e
draw :: Affection UserData () draw :: Affection UserData ()
draw = do draw = do
GL.viewport $= (GL.Position 0 0, GL.Size 800 600) return ()
ud <- getAffection -- GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
GL.currentProgram $= (Just . GLU.program $ program sd) -- ud <- getAffection
let proj = ortho (-1) 1 (-1) 1 (-1) 1 -- GL.currentProgram $= (Just . GLU.program $ program sd)
view = lookAt -- let proj = ortho (-1) 1 (-1) 1 (-1) 1
(V3 0 0 (-1)) -- view = lookAt
(V3 0 0 0) -- (V3 0 0 (-1))
(V3 0 1 0) -- (V3 0 0 0)
model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0) -- (V3 0 1 0)
-- model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)

View file

@ -1,73 +1,71 @@
module Menu where module Menu where
import Affection import Affection as A
import qualified SDL import qualified SDL
import Debug.Trace import Debug.Trace
import Types import Data.Maybe
handleMenuEvent :: SDL.EventPayload -> Affection UserData () import Control.Monad (when)
handleMenuEvent e = import Control.Monad.IO.Class (liftIO)
case e of
SDL.KeyboardEvent dat -> import qualified Data.Map as M
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeSpace -> import NanoVG
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
ud <- getAffection -- internal imports
liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyFGNop) "input"
smLoad InGame import Types
_ -> return () import Commons
SDL.WindowClosedEvent _ -> do
ad <- get handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData ()
put ad handleMenuEvent loader es =
{ quitEvent = True mapM_ (\e ->
} case e of
_ -> return () 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
loadMenu :: Affection UserData () loadMenu :: Affection UserData ()
loadMenu = do loadMenu = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection ud <- getAffection
liftIO $ gegl_node_connect_to mhaskImage <- liftIO $
(nodeGraph ud M.! KeyMenuOver) createImage (nano ud) (FileName "assets/haskelloid.svg") 0
"output" when (isNothing mhaskImage) $
(nodeGraph ud M.! KeyFGOver) liftIO $ logIO Error "Failed to load asset haskelloid"
"aux" hs <- newHaskelloids (fromJust mhaskImage)
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
px <- randomRIO (0, 800)
py <- randomRIO (0, 600)
insertHaskelloid acc Nothing (px, py)
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
-- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyPNop) "input"
putAffection ud putAffection ud
{ haskelloids = hs { haskelloids = hs
, fade = FadeIn 1 , fade = FadeIn 1
, state = Menu , state = Menu
, shots = (shots ud) -- , shots = (shots ud)
{ partSysParts = ParticleStorage Nothing [] } -- { partSysParts = ParticleStorage Nothing [] }
} }
updateMenu :: Double -> Affection UserData () updateMenu :: Double -> Affection UserData ()
updateMenu sec = do updateMenu sec = do
ud <- getAffection ud <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud) let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of case fade ud of
FadeIn ttl -> do FadeIn ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 (1.1 - ttl)
]
putAffection ud putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1 { fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs , haskelloids = nhs
} }
FadeOut ttl -> do FadeOut ttl -> do
liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
Operation "gegl:text"
[ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 ttl
]
putAffection ud putAffection ud
{ 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

View file

@ -4,7 +4,6 @@ module StateMachine where
import Affection import Affection
import qualified SDL import qualified SDL
import GEGL
import qualified Data.Map as M import qualified Data.Map as M
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
@ -15,22 +14,22 @@ import System.Random (randomRIO)
import Types import Types
import Commons import Commons
import InGame -- import InGame
import Menu import Menu
instance StateMachine State UserData where instance StateMachine State UserData where
smLoad Menu = loadMenu smLoad Menu = loadMenu
smLoad InGame = loadGame -- smLoad InGame = loadGame
smUpdate Menu = updateMenu smUpdate Menu = updateMenu
smUpdate InGame sec = updateGame sec -- smUpdate InGame sec = updateGame sec
smEvent Menu = handleMenuEvent smEvent Menu = handleMenuEvent (return ()) -- (smLoad InGame)
smEvent InGame = handleGameEvent -- smEvent InGame = handleGameEvent
smDraw Menu = return () smDraw Menu = return ()
smDraw InGame = drawGame -- smDraw InGame = drawGame

View file

@ -4,7 +4,8 @@ module Types where
import Affection import Affection
import qualified SDL import qualified SDL
import NanoVG import NanoVG hiding (V2(..))
import Linear
data UserData = UserData data UserData = UserData
{ ship :: Ship { ship :: Ship
@ -15,7 +16,7 @@ data UserData = UserData
, pixelSize :: Int , pixelSize :: Int
, state :: State , state :: State
, fade :: MenuFade , fade :: MenuFade
, neno :: Context , nano :: Context
} }
data Ship = Ship data Ship = Ship