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.config
dist/
*.prof
*.aux
*.hp
*.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
-- Modules included in this executable, other than Main.
other-modules: InGame
, Types
other-modules: Types
, Commons
, StateMachine
, Menu
, Init
default-extensions: OverloadedStrings
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:

View file

@ -4,18 +4,19 @@ module Commons where
import Affection
import qualified SDL
import GEGL
import BABL
import qualified Data.Map as M
import Data.List (delete)
import Data.Maybe (catMaybes, isJust)
import Control.Monad (foldM, unless, when)
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import Debug.Trace
import NanoVG hiding (V2(..))
import Linear
import Types
@ -33,3 +34,28 @@ wrapAround (nx, ny) width = (nnx, nny)
| ny > 600 = ny - (600 + width)
| ny < -width = ny + 600 + width
| 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
import Affection
import Affection as A
import SDL (($=))
import qualified SDL
@ -8,9 +8,14 @@ import qualified SDL
import qualified Data.Set as S
import Data.Maybe
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import System.Random
import NanoVG
import NanoVG hiding (V2(..))
import Linear
-- Internal imports
@ -18,33 +23,19 @@ import Types
load :: IO UserData
load = do
liftIO $ logIO A.Debug "loading state"
liftIO $ logIO A.Debug "creating NanoVG context"
nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
mhaskImage <- createImage nvgCtx "assets/haskelloid.svg" 0
mshipImage <- createImage nvgCtx "assets/ship.svg" 0
when (isNothing mhasImage || isNothing mshipImage) $
liftIO $ logIO A.Debug "load ship image"
mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0
when (isNothing mshipImage) $
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
{ ship = Ship
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sImg = fromust mshipImage
, sImg = fromJust mshipImage
}
, haskelloids = []
, wonlost = Nothing

View file

@ -5,9 +5,6 @@ import Affection
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
import qualified Data.Map as M
import Linear as L
@ -25,7 +22,7 @@ main = do
withAffection AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = defaultWindow
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
@ -37,7 +34,7 @@ main = do
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = clean
, cleanUp = (\_ -> return ())
}
update :: Double -> Affection UserData ()
@ -45,19 +42,20 @@ update sec = do
ud <- getAffection
smUpdate (state ud) sec
handle :: SDL.EventPayload -> Affection UserData ()
handle :: [SDL.EventPayload] -> Affection UserData ()
handle e = do
ud <- getAffection
smEvent (state ud) e
draw :: Affection UserData ()
draw = do
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
ud <- getAffection
GL.currentProgram $= (Just . GLU.program $ program sd)
let proj = ortho (-1) 1 (-1) 1 (-1) 1
view = lookAt
(V3 0 0 (-1))
(V3 0 0 0)
(V3 0 1 0)
model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)
return ()
-- GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
-- ud <- getAffection
-- GL.currentProgram $= (Just . GLU.program $ program sd)
-- let proj = ortho (-1) 1 (-1) 1 (-1) 1
-- view = lookAt
-- (V3 0 0 (-1))
-- (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
import Affection
import Affection as A
import qualified SDL
import Debug.Trace
import Types
import Data.Maybe
handleMenuEvent :: SDL.EventPayload -> Affection UserData ()
handleMenuEvent 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
liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyFGNop) "input"
smLoad InGame
_ -> return ()
SDL.WindowClosedEvent _ -> do
ad <- get
put ad
{ quitEvent = True
}
_ -> return ()
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import qualified Data.Map as M
import NanoVG
-- internal imports
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
loadMenu :: Affection UserData ()
loadMenu = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection
liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyMenuOver)
"output"
(nodeGraph ud M.! KeyFGOver)
"aux"
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"
mhaskImage <- liftIO $
createImage (nano ud) (FileName "assets/haskelloid.svg") 0
when (isNothing mhaskImage) $
liftIO $ logIO Error "Failed to load asset haskelloid"
hs <- newHaskelloids (fromJust mhaskImage)
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, shots = (shots ud)
{ partSysParts = ParticleStorage Nothing [] }
-- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] }
}
updateMenu :: Double -> Affection UserData ()
updateMenu sec = do
ud <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud)
let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of
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
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
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
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs

View file

@ -4,7 +4,6 @@ module StateMachine where
import Affection
import qualified SDL
import GEGL
import qualified Data.Map as M
import Data.Maybe (catMaybes)
@ -15,22 +14,22 @@ import System.Random (randomRIO)
import Types
import Commons
import InGame
-- import InGame
import Menu
instance StateMachine State UserData where
smLoad Menu = loadMenu
smLoad InGame = loadGame
-- smLoad InGame = loadGame
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 InGame = drawGame
-- smDraw InGame = drawGame

View file

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