initiating rewrite
This commit is contained in:
nek0
parent
25d45277a0
commit
31fd771e64
8 changed files with 295 additions and 740 deletions
|
|
@ -57,6 +57,7 @@ executable haskelloids
|
|||
, Types
|
||||
, Commons
|
||||
, StateMachine
|
||||
, Menu
|
||||
|
||||
-- LANGUAGE extensions used by modules in this package.
|
||||
-- other-extensions:
|
||||
|
|
@ -64,11 +65,11 @@ executable haskelloids
|
|||
-- Other library packages from which modules are imported.
|
||||
build-depends: base >=4.9 && <4.11
|
||||
, affection
|
||||
, gegl
|
||||
, babl
|
||||
, sdl2 >= 2.1.3.1
|
||||
, containers
|
||||
, random
|
||||
, nanovg
|
||||
, linear
|
||||
|
||||
-- Directories containing source files.
|
||||
hs-source-dirs: src
|
||||
|
|
|
|||
353
src/Commons.hs
353
src/Commons.hs
|
|
@ -9,9 +9,9 @@ import BABL
|
|||
|
||||
import qualified Data.Map as M
|
||||
import Data.List (delete)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Maybe (catMaybes, isJust)
|
||||
|
||||
import Control.Monad (foldM, unless)
|
||||
import Control.Monad (foldM, unless, when)
|
||||
|
||||
import System.Random (randomRIO)
|
||||
|
||||
|
|
@ -22,296 +22,6 @@ import Types
|
|||
toR :: Double -> Double
|
||||
toR deg = deg * pi / 180
|
||||
|
||||
clean :: UserData -> IO ()
|
||||
clean ud = do
|
||||
mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
|
||||
gegl_node_drop $ nodeGraph ud M.! KeyRoot
|
||||
|
||||
load :: IO UserData
|
||||
load = do
|
||||
traceM "loading"
|
||||
root <- gegl_node_new
|
||||
traceM "root node"
|
||||
bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
|
||||
[ Property "x" $ PropertyDouble 0
|
||||
, Property "y" $ PropertyDouble 0
|
||||
, Property "width" $ PropertyDouble 800
|
||||
, Property "height" $ PropertyDouble 600
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
|
||||
]
|
||||
shipNode <- gegl_node_new_child root $ Operation "gegl:svg-load"
|
||||
[ Property "path" $ PropertyString "assets/ship.svg"
|
||||
, Property "width" $ PropertyInt 50
|
||||
, Property "height" $ PropertyInt 50
|
||||
]
|
||||
pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
|
||||
hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
|
||||
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
|
||||
sover <- gegl_node_new_child root defaultOverOperation
|
||||
hover <- gegl_node_new_child root defaultOverOperation
|
||||
pover <- gegl_node_new_child root defaultOverOperation
|
||||
bgover <- gegl_node_new_child root defaultOverOperation
|
||||
fgover <- gegl_node_new_child root defaultOverOperation
|
||||
translate <- gegl_node_new_child root $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble 375
|
||||
, Property "y" $ PropertyDouble 275
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble 150
|
||||
, Property "y" $ PropertyDouble 250
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
|
||||
[ Property "origin-x" $ PropertyDouble 25
|
||||
, Property "origin-y" $ PropertyDouble 25
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
crop <- gegl_node_new_child root $ Operation "gegl:crop"
|
||||
[ Property "width" $ PropertyDouble 800
|
||||
, Property "height" $ PropertyDouble 600
|
||||
]
|
||||
nbuffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
|
||||
babl_format (PixelFormat BABL.RGBA CFfloat)
|
||||
sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
|
||||
[ Property "buffer" $ PropertyBuffer nbuffer
|
||||
]
|
||||
won <- gegl_node_new_child root $ textOperation
|
||||
[ Property "string" $ PropertyString "YOU WON!"
|
||||
, Property "font" $ PropertyString "Modulo"
|
||||
, Property "size" $ PropertyDouble 100
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
lost <- gegl_node_new_child root $ textOperation
|
||||
[ Property "string" $ PropertyString "YOU LOST!"
|
||||
, Property "font" $ PropertyString "Modulo"
|
||||
, Property "size" $ PropertyDouble 100
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
vignette <- gegl_node_new_child root $ Operation "gegl:vignette" []
|
||||
pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
|
||||
[ Property "size-x" $ PropertyInt 3
|
||||
, Property "size-y" $ PropertyInt 3
|
||||
]
|
||||
-- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
|
||||
-- [ Property "pattern" $ PropertyInt 8
|
||||
-- ]
|
||||
menuHeading <- gegl_node_new_child root $ textOperation
|
||||
[ Property "string" $ PropertyString "Haskelloids"
|
||||
, Property "font" $ PropertyString "Modulo"
|
||||
, Property "size" $ PropertyDouble 100
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
menuText <- gegl_node_new_child root $ textOperation
|
||||
[ Property "string" $ PropertyString "Press [Space] to start"
|
||||
, Property "font" $ PropertyString "Modulo"
|
||||
, Property "size" $ PropertyDouble 50
|
||||
, Property "alignment" $ PropertyInt 1
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
menuTranslateHeading <- gegl_node_new_child root $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble 150
|
||||
, Property "y" $ PropertyDouble 100
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
menuTranslateText <- gegl_node_new_child root $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble 130
|
||||
, Property "y" $ PropertyDouble 300
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
menuOver <- gegl_node_new_child root defaultOverOperation
|
||||
gegl_node_link menuHeading menuTranslateHeading
|
||||
gegl_node_link_many [menuText, menuTranslateText, menuOver]
|
||||
_ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux"
|
||||
gegl_node_link_many [shipNode, rotate, translate]
|
||||
gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink]
|
||||
-- _ <- gegl_node_connect_to translate "output" sover "aux"
|
||||
_ <- gegl_node_connect_to pnop "output" pover "aux"
|
||||
_ <- gegl_node_connect_to hnop "output" hover "aux"
|
||||
_ <- gegl_node_connect_to bg "output" bgover "aux"
|
||||
liftIO $ gegl_node_link fgnop fgtranslate
|
||||
-- _ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
|
||||
_ <- gegl_node_connect_to fgnop "output" fgover "aux"
|
||||
traceM "nodes complete"
|
||||
myMap <- return $ M.fromList
|
||||
[ (KeyRoot, root)
|
||||
, (KeyShip, shipNode)
|
||||
, (KeyShipTranslate, translate)
|
||||
, (KeyShipRotate, rotate)
|
||||
, (KeyPNop, pnop)
|
||||
, (KeyHNop, hnop)
|
||||
, (KeyCrop, crop)
|
||||
, (KeyShipOver, sover)
|
||||
, (KeySink, sink)
|
||||
, (KeyWon, won)
|
||||
, (KeyLost, lost)
|
||||
, (KeyPixelize, pixelize)
|
||||
, (KeyFGOver, fgover)
|
||||
, (KeyFGNop, fgnop)
|
||||
, (KeyFGTrans, fgtranslate)
|
||||
, (KeyMenuHeading, menuTranslateHeading)
|
||||
, (KeyMenuText, menuText)
|
||||
, (KeyMenuOver, menuOver)
|
||||
]
|
||||
traceM "built map"
|
||||
hs <- catMaybes <$> foldM (\acc _ -> do
|
||||
px <- liftIO $ randomRIO (0, 800)
|
||||
py <- liftIO $ randomRIO (0, 600)
|
||||
insertHaskelloid acc Nothing (px, py)
|
||||
) [] ([0..9] :: [Int])
|
||||
traceM "built haskelloids"
|
||||
liftIO $ gegl_node_link_many $ map hFlange hs
|
||||
liftIO $ gegl_node_link (last $ map hFlange hs) hnop
|
||||
traceM "linking haskelloids and returning UserData"
|
||||
return $ UserData
|
||||
{ nodeGraph = myMap
|
||||
, ship = Ship
|
||||
{ sPos = (375, 275)
|
||||
, sVel = (0, 0)
|
||||
, sRot = 0
|
||||
, sFlange = rotate
|
||||
}
|
||||
, buffer = nbuffer
|
||||
, shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer
|
||||
-- , haskelloids = hs
|
||||
, haskelloids = []
|
||||
, wonlost = False
|
||||
, pixelSize = 3
|
||||
, state = Menu
|
||||
, fade = FadeIn 1
|
||||
}
|
||||
|
||||
insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
|
||||
insertHaskelloid hasks split (px, py) = do
|
||||
liftIO $ traceIO "inserting haskelloid"
|
||||
vx <- liftIO $ randomRIO (-10, 10)
|
||||
vy <- liftIO $ randomRIO (-10, 10)
|
||||
rdiv <- case split of
|
||||
Nothing -> liftIO $ randomRIO (1, 2)
|
||||
Just x -> return $ x + 1
|
||||
rot <- liftIO $ randomRIO ((-180) , 180)
|
||||
pitch <- liftIO $ randomRIO ((-(pi/2)), pi/2)
|
||||
tempRoot <- liftIO $ gegl_node_new
|
||||
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
|
||||
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:png-load"
|
||||
[ Property "path" $ PropertyString "assets/haskelloid.png"
|
||||
]
|
||||
liftIO $ traceIO "svg loaded"
|
||||
tempScale <- gegl_node_new_child tempRoot $ Operation "gegl:scale-size"
|
||||
[ Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
, Property "x" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
|
||||
, Property "y" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
|
||||
]
|
||||
liftIO $ traceIO "scaled"
|
||||
tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
|
||||
, Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
liftIO $ traceIO "translated"
|
||||
tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
|
||||
[ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
|
||||
, Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
|
||||
, Property "degrees" $ PropertyDouble rot
|
||||
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
|
||||
]
|
||||
liftIO $ traceIO $ "rotated: " ++ show rot
|
||||
liftIO $ gegl_node_link_many [tempSvg, tempScale, tempRot, tempTrans]
|
||||
_ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
|
||||
return $ Just Haskelloid
|
||||
{ hPos =
|
||||
( px + (100 / 2 / fromIntegral rdiv)
|
||||
, py + (100 / 2 / fromIntegral rdiv)
|
||||
)
|
||||
, hVel = (vx, vy)
|
||||
, hRot = rot
|
||||
, hPitch = pitch
|
||||
, hDiv = rdiv
|
||||
, hFlange = tempOver
|
||||
, hNodeGraph = M.fromList
|
||||
[ ("root", tempRoot)
|
||||
, ("over", tempOver)
|
||||
, ("svg", tempSvg)
|
||||
, ("trans", tempTrans)
|
||||
, ("rot", tempRot)
|
||||
]
|
||||
} : hasks
|
||||
|
||||
haskelloidShotDown :: Haskelloid -> Affection UserData ()
|
||||
haskelloidShotDown h = do
|
||||
ud <- getAffection
|
||||
-- liftIO $ traceIO $ show $ length $ haskelloids ud
|
||||
let redHaskelloids = delete h (haskelloids ud)
|
||||
newHaskelloids <- catMaybes <$> foldM
|
||||
(\acc _ ->
|
||||
if hDiv h < 4
|
||||
then
|
||||
liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
|
||||
else
|
||||
return $ Nothing : acc
|
||||
)
|
||||
(map Just redHaskelloids) ([0..1] :: [Int])
|
||||
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
|
||||
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
|
||||
if not $ null newHaskelloids
|
||||
then
|
||||
liftIO $ gegl_node_link
|
||||
(last $ map hFlange newHaskelloids)
|
||||
(nodeGraph ud M.! KeyHNop)
|
||||
else do
|
||||
liftIO $ traceIO "YOU WON!"
|
||||
_ <- liftIO $ gegl_node_link
|
||||
(nodeGraph ud M.! KeyWon)
|
||||
(nodeGraph ud M.! KeyFGTrans)
|
||||
_ <- liftIO $ gegl_node_connect_to
|
||||
(nodeGraph ud M.! KeyFGTrans)
|
||||
"output"
|
||||
(nodeGraph ud M.! KeyFGOver)
|
||||
"aux"
|
||||
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
|
||||
putAffection ud
|
||||
{ wonlost = True
|
||||
}
|
||||
ud2 <- getAffection
|
||||
putAffection ud2
|
||||
{ haskelloids = newHaskelloids
|
||||
}
|
||||
|
||||
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
|
||||
updateHaskelloid sec h@Haskelloid{..} = do
|
||||
let newX = fst hPos + sec * fst hVel
|
||||
newY = snd hPos + sec * snd hVel
|
||||
newRot = hRot + hPitch * sec
|
||||
(nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
|
||||
-- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
|
||||
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
|
||||
[ Property "x" $ PropertyDouble nnx
|
||||
, Property "y" $ PropertyDouble nny
|
||||
]
|
||||
liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
|
||||
[ Property "degrees" $ PropertyDouble newRot
|
||||
]
|
||||
ud <- getAffection
|
||||
lost <-
|
||||
case state ud of
|
||||
InGame -> liftIO $ gegl_rectangle_intersect
|
||||
(GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
|
||||
(GeglRectangle
|
||||
(floor $ fst $ sPos $ ship ud)
|
||||
(floor $ snd $ sPos $ ship ud)
|
||||
50
|
||||
50
|
||||
)
|
||||
_ -> return Nothing
|
||||
maybe (return ()) (const $ do
|
||||
lose
|
||||
putAffection ud {wonlost = True}
|
||||
) lost
|
||||
return h
|
||||
{ hPos = (nnx, nny)
|
||||
, hRot = newRot
|
||||
}
|
||||
|
||||
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
|
||||
wrapAround (nx, ny) width = (nnx, nny)
|
||||
where
|
||||
|
|
@ -323,62 +33,3 @@ wrapAround (nx, ny) width = (nnx, nny)
|
|||
| ny > 600 = ny - (600 + width)
|
||||
| ny < -width = ny + 600 + width
|
||||
| otherwise = ny
|
||||
|
||||
shotsUpd :: Double -> Particle -> Affection UserData Particle
|
||||
shotsUpd sec part@Particle{..} = do
|
||||
let newX = fst particlePosition + sec * fromIntegral (fst particleVelocity)
|
||||
newY = snd particlePosition + sec * fromIntegral (snd particleVelocity)
|
||||
(nnx, nny) = wrapAround (newX, newY) 4
|
||||
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
|
||||
[ Property "x" $ PropertyDouble nnx
|
||||
, Property "y" $ PropertyDouble nny
|
||||
]
|
||||
ud <- getAffection
|
||||
inters <- catMaybes <$> mapM (\h -> do
|
||||
col <- liftIO $ gegl_rectangle_intersect
|
||||
(GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||
(GeglRectangle
|
||||
(floor $ fst $ hPos h)
|
||||
(floor $ snd $ hPos h)
|
||||
(100 `div` hDiv h)
|
||||
(100 `div` hDiv h)
|
||||
)
|
||||
case col of
|
||||
Just _ -> return $ Just h
|
||||
Nothing -> return Nothing
|
||||
) (haskelloids ud)
|
||||
unless (null inters) $
|
||||
haskelloidShotDown $ head inters
|
||||
lost <- liftIO $ gegl_rectangle_intersect
|
||||
(GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||
(GeglRectangle
|
||||
(floor $ fst $ sPos $ ship ud)
|
||||
(floor $ snd $ sPos $ ship ud)
|
||||
50
|
||||
50
|
||||
)
|
||||
maybe (return ()) (const lose) lost
|
||||
return part
|
||||
{ particlePosition = (nnx, nny)
|
||||
, particleTimeToLive = if not $ null inters then 0 else particleTimeToLive
|
||||
}
|
||||
|
||||
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
|
||||
shotsDraw _ _ _ = return ()
|
||||
|
||||
lose :: Affection UserData ()
|
||||
lose = do
|
||||
ud <- getAffection
|
||||
liftIO $ traceIO "YOU LOST!"
|
||||
_ <- liftIO $ gegl_node_link
|
||||
(nodeGraph ud M.! KeyLost)
|
||||
(nodeGraph ud M.! KeyFGTrans)
|
||||
_ <- liftIO $ gegl_node_connect_to
|
||||
(nodeGraph ud M.! KeyFGTrans)
|
||||
"output"
|
||||
(nodeGraph ud M.! KeyFGOver)
|
||||
"aux"
|
||||
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
|
||||
putAffection ud
|
||||
{ wonlost = True
|
||||
}
|
||||
|
|
|
|||
155
src/InGame.hs
155
src/InGame.hs
|
|
@ -5,7 +5,7 @@ import qualified SDL
|
|||
import GEGL
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
|
||||
|
||||
import Control.Monad (when, foldM)
|
||||
|
||||
|
|
@ -40,7 +40,7 @@ loadGame = do
|
|||
liftIO $ traceIO "nodes linked"
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, wonlost = False
|
||||
, wonlost = Nothing
|
||||
, shots = ParticleSystem
|
||||
(ParticleStorage Nothing [])
|
||||
(nodeGraph ud M.! KeyPNop)
|
||||
|
|
@ -108,11 +108,10 @@ updateGame sec = do
|
|||
putAffection ud3
|
||||
{ haskelloids = nhs
|
||||
}
|
||||
-- liftIO $ traceIO $ show $ length nhs
|
||||
ud3 <- getAffection
|
||||
-- ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
||||
ups <- updateParticleSystem (shots ud3) sec shotsUpd
|
||||
ud4 <- getAffection
|
||||
when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
|
||||
putAffection ud4
|
||||
{ shots = ups
|
||||
}
|
||||
|
|
@ -136,81 +135,99 @@ handleGameEvent e = do
|
|||
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
|
||||
SDL.KeycodeLeft -> do
|
||||
ud <- getAffection
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = (sRot $ ship ud) + 15 * sec
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost ud)) $ do
|
||||
let rawRot = (sRot $ ship ud) + 15 * sec
|
||||
newRot
|
||||
| rawRot > 360 = rawRot - 360
|
||||
| rawRot < 0 = rawRot + 360
|
||||
| otherwise = rawRot
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = newRot
|
||||
}
|
||||
}
|
||||
}
|
||||
SDL.KeycodeRight -> do
|
||||
ud <- getAffection
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = (sRot $ ship ud) - 15 * sec
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost ud)) $ do
|
||||
let rawRot = (sRot $ ship ud) - 15 * sec
|
||||
newRot
|
||||
| rawRot > 360 = rawRot - 360
|
||||
| rawRot < 0 = rawRot + 360
|
||||
| otherwise = rawRot
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sRot = newRot
|
||||
}
|
||||
}
|
||||
}
|
||||
SDL.KeycodeUp ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
|
||||
vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sVel = (vx, vy)
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
|
||||
vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
|
||||
putAffection ud
|
||||
{ ship = (ship ud)
|
||||
{ sVel = (vx, vy)
|
||||
}
|
||||
}
|
||||
}
|
||||
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
||||
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
|
||||
SDL.KeycodeSpace ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
|
||||
[ Property "size-x" $ PropertyInt 8
|
||||
, Property "size-y" $ PropertyInt 8
|
||||
]
|
||||
-- ad <- get
|
||||
let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
|
||||
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
|
||||
tempRoot <- liftIO gegl_node_new
|
||||
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
|
||||
[ Property "x" $ PropertyDouble posX
|
||||
, Property "y" $ PropertyDouble posY
|
||||
, Property "width" $ PropertyDouble 4
|
||||
, Property "height" $ PropertyDouble 4
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
|
||||
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
|
||||
ips <- insertParticle (shots ud)
|
||||
Particle
|
||||
{ particleTimeToLive = 5
|
||||
, particleCreation = elapsedTime ad
|
||||
, particlePosition = (posX, posY)
|
||||
, particleRotation = 0
|
||||
, particleVelocity =
|
||||
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
|
||||
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
|
||||
)
|
||||
, particlePitchRate = 0
|
||||
, particleRootNode = tempRoot
|
||||
, particleNodeGraph = M.fromList
|
||||
[ ("root", tempRoot)
|
||||
, ("over", tempOver)
|
||||
, ("rect", tempRect)
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& (isNothing $ wonlost wd)) $ do
|
||||
ud <- getAffection
|
||||
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
|
||||
Operation "gegl:pixelize"
|
||||
[ Property "size-x" $ PropertyInt 8
|
||||
, Property "size-y" $ PropertyInt 8
|
||||
]
|
||||
, particleStackCont = tempOver
|
||||
, particleDrawFlange = tempOver
|
||||
-- ad <- get
|
||||
let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
|
||||
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
|
||||
tempRoot <- liftIO gegl_node_new
|
||||
tempRect <- liftIO $ gegl_node_new_child tempRoot $
|
||||
Operation "gegl:rectangle"
|
||||
[ Property "x" $ PropertyDouble posX
|
||||
, Property "y" $ PropertyDouble posY
|
||||
, Property "width" $ PropertyDouble 4
|
||||
, Property "height" $ PropertyDouble 4
|
||||
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
|
||||
]
|
||||
tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
|
||||
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
|
||||
ips <- insertParticle (shots ud)
|
||||
Particle
|
||||
{ particleTimeToLive = 5
|
||||
, particleCreation = elapsedTime ad
|
||||
, particlePosition = (posX, posY)
|
||||
, particleRotation = 0
|
||||
, particleVelocity =
|
||||
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
|
||||
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
|
||||
)
|
||||
, particlePitchRate = 0
|
||||
, particleRootNode = tempRoot
|
||||
, particleNodeGraph = M.fromList
|
||||
[ ("root", tempRoot)
|
||||
, ("over", tempOver)
|
||||
, ("rect", tempRect)
|
||||
]
|
||||
, particleStackCont = tempOver
|
||||
, particleDrawFlange = tempOver
|
||||
}
|
||||
putAffection $ ud
|
||||
{ shots = ips
|
||||
, pixelSize = 8
|
||||
}
|
||||
putAffection $ ud
|
||||
{ shots = ips
|
||||
, pixelSize = 8
|
||||
}
|
||||
SDL.KeycodeR ->
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && wonlost wd) $ do
|
||||
liftIO $ traceIO "reloading"
|
||||
liftIO $ clean wd
|
||||
nd <- liftIO $ load
|
||||
putAffection nd
|
||||
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
|
||||
&& isJust (wonlost wd)) $ do
|
||||
liftIO $ traceIO "reloading"
|
||||
liftIO $ clean wd
|
||||
nd <- liftIO $ load
|
||||
putAffection nd
|
||||
loadGame
|
||||
_ -> return ()
|
||||
SDL.WindowClosedEvent _ -> do
|
||||
traceM "seeya!"
|
||||
|
|
|
|||
81
src/Init.hs
Normal file
81
src/Init.hs
Normal file
|
|
@ -0,0 +1,81 @@
|
|||
module Init where
|
||||
|
||||
import Affection
|
||||
|
||||
import SDL (($=))
|
||||
import qualified SDL
|
||||
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
|
||||
import System.Random
|
||||
|
||||
import NanoVG
|
||||
|
||||
-- Internal imports
|
||||
|
||||
import Types
|
||||
|
||||
load :: IO UserData
|
||||
load = do
|
||||
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) $
|
||||
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
|
||||
}
|
||||
, haskelloids = []
|
||||
, wonlost = Nothing
|
||||
, state = Menu
|
||||
, fade = FadeIn 1
|
||||
, nano = nvgCtx
|
||||
}
|
||||
|
||||
|
||||
|
||||
-- _ <- SDL.setMouseLocationMode SDL.RelativeLocation
|
||||
-- GL.depthFunc $= ust GL.Less
|
||||
-- pane <- GL.genObjectName
|
||||
-- GL.BindVertexArrayObject $= Just pane
|
||||
-- verts <- GL.genObejctName
|
||||
-- let vertCoord =
|
||||
-- [ (-1), (-1), 0
|
||||
-- , 1 , (-1), 0
|
||||
-- , (-1), 1 , 0
|
||||
-- , 1 , 1 , 0
|
||||
-- , (-1), 1 , 0
|
||||
-- , 1 , (-1), 0
|
||||
-- ]
|
||||
-- withArray vertCoord $ \ptr
|
||||
-- GL.bufferData GL.ArrayBuffer $=
|
||||
-- ( fromIntegral $ length vertCoord * 3 * sizeOf (0 :: Double)
|
||||
-- , ptr
|
||||
-- , GL.StaticDraw
|
||||
-- )
|
||||
-- GL.vertexAttribPointer (GL.AttribLocation 0) $=
|
||||
-- ( GL.ToFloat
|
||||
-- , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0)
|
||||
-- )
|
||||
-- GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
|
||||
237
src/Main.hs
237
src/Main.hs
|
|
@ -1,222 +1,63 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
import Affection hiding (StateMachine(..))
|
||||
import Affection
|
||||
import SDL (($=))
|
||||
import qualified SDL
|
||||
import GEGL
|
||||
|
||||
import Data.List (delete)
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Graphics.GLUtil as GLU
|
||||
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (catMaybes)
|
||||
|
||||
import Control.Monad (when, foldM)
|
||||
|
||||
import Debug.Trace
|
||||
import Linear as L
|
||||
|
||||
-- internal imports
|
||||
|
||||
import Types
|
||||
import Commons
|
||||
import StateMachine
|
||||
|
||||
import Menu
|
||||
import InGame
|
||||
import StateMachine ()
|
||||
import Init
|
||||
|
||||
main :: IO ()
|
||||
main = withAffection AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "Haskelloids"
|
||||
, windowConfig = defaultWindow
|
||||
, initScreenMode = SDL.Windowed
|
||||
, preLoop = return ()
|
||||
, drawLoop = draw
|
||||
, updateLoop = update
|
||||
, loadState = load
|
||||
, cleanUp = clean
|
||||
, canvasSize = Nothing
|
||||
, eventLoop = handleGameEvent
|
||||
}
|
||||
main = do
|
||||
logIO Debug "Starting"
|
||||
withAffection AffectionConfig
|
||||
{ initComponents = All
|
||||
, windowTitle = "Haskelloids"
|
||||
, windowConfig = defaultWindow
|
||||
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
|
||||
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
|
||||
}
|
||||
}
|
||||
, initScreenMode = SDL.Windowed
|
||||
, canvasSize = Nothing
|
||||
, loadState = load
|
||||
, preLoop = smLoad Menu
|
||||
, eventLoop = handle
|
||||
, updateLoop = update
|
||||
, drawLoop = draw
|
||||
, cleanUp = clean
|
||||
}
|
||||
|
||||
update :: Double -> Affection UserData ()
|
||||
update sec = do
|
||||
ud <- getAffection
|
||||
smUpdate (state ud) sec
|
||||
|
||||
-- update sec = do
|
||||
-- -- traceM $ (show $ 1 / sec) ++ " FPS"
|
||||
-- ad <- get
|
||||
-- wd <- getAffection
|
||||
-- when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
|
||||
-- liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
|
||||
-- [ Property "size-x" $ PropertyInt $ pixelSize wd - 1
|
||||
-- , Property "size-y" $ PropertyInt $ pixelSize wd - 1
|
||||
-- ]
|
||||
-- pd <- getAffection
|
||||
-- putAffection pd
|
||||
-- { pixelSize = pixelSize wd -1
|
||||
-- }
|
||||
-- -- evs <- SDL.pollEvents
|
||||
-- -- mapM_ (\e ->
|
||||
-- -- case state wd of
|
||||
-- -- InGame ->
|
||||
-- -- handleGameEvent sec e
|
||||
-- -- _ -> error "not yet implemented"
|
||||
-- -- ) evs
|
||||
-- ud2 <- getAffection
|
||||
-- nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
|
||||
-- -- liftIO $ traceIO $ show $ length nhs
|
||||
-- putAffection ud2
|
||||
-- { haskelloids = nhs
|
||||
-- }
|
||||
-- ud3 <- getAffection
|
||||
-- let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
|
||||
-- ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
|
||||
-- (nnx, nny) = wrapAround (nx, ny) 50
|
||||
-- liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipTranslate) $ Operation "gegl:translate"
|
||||
-- [ Property "x" $ PropertyDouble $ nnx
|
||||
-- , Property "y" $ PropertyDouble $ nny
|
||||
-- ]
|
||||
-- liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipRotate) $ Operation "gegl:rotate"
|
||||
-- [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
|
||||
-- ]
|
||||
-- ups <- updateParticleSystem (shots ud3) sec shotsUpd
|
||||
-- ud4 <- getAffection
|
||||
-- putAffection ud4
|
||||
-- { ship = (ship ud3)
|
||||
-- { sPos = (nnx, nny)
|
||||
-- }
|
||||
-- , shots = ups
|
||||
-- }
|
||||
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
|
||||
smDraw (state ud)
|
||||
-- drawParticleSystem (shots ud) (\_ _ _ -> return())
|
||||
-- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
|
||||
-- present
|
||||
-- (GeglRectangle 0 0 800 600)
|
||||
-- (buffer ud)
|
||||
-- True
|
||||
-- render Nothing Nothing
|
||||
|
||||
-- shotsUpd :: Double -> Particle -> Affection UserData Particle
|
||||
-- shotsUpd sec part@Particle{..} = do
|
||||
-- let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
|
||||
-- newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
|
||||
-- (nnx, nny) = wrapAround (newX, newY) 4
|
||||
-- liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
|
||||
-- [ Property "x" $ PropertyDouble $ nnx
|
||||
-- , Property "y" $ PropertyDouble $ nny
|
||||
-- ]
|
||||
-- ud <- getAffection
|
||||
-- inters <- catMaybes <$> mapM (\h -> do
|
||||
-- col <- liftIO $ gegl_rectangle_intersect
|
||||
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||
-- (GeglRectangle
|
||||
-- (floor $ fst $ hPos h)
|
||||
-- (floor $ snd $ hPos h)
|
||||
-- (100 `div` hDiv h)
|
||||
-- (100 `div` hDiv h)
|
||||
-- )
|
||||
-- case col of
|
||||
-- Just _ -> return $ Just h
|
||||
-- Nothing -> return Nothing
|
||||
-- ) (haskelloids ud)
|
||||
-- when (not $ null inters) $
|
||||
-- haskelloidShotDown $ head inters
|
||||
-- lost <- liftIO $ gegl_rectangle_intersect
|
||||
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||
-- (GeglRectangle
|
||||
-- (floor $ fst $ sPos $ ship ud)
|
||||
-- (floor $ snd $ sPos $ ship ud)
|
||||
-- 50
|
||||
-- 50
|
||||
-- )
|
||||
-- maybe (return ()) (\_ ->
|
||||
-- lose
|
||||
-- ) lost
|
||||
-- return part
|
||||
-- { particlePosition = (nnx, nny)
|
||||
-- , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
|
||||
-- }
|
||||
|
||||
haskelloidShotDown :: Haskelloid -> Affection UserData ()
|
||||
haskelloidShotDown h = do
|
||||
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
|
||||
ud <- getAffection
|
||||
let redHaskelloids = delete h (haskelloids ud)
|
||||
liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
|
||||
newHaskelloids <- catMaybes <$> foldM
|
||||
(\acc _ ->
|
||||
if hDiv h < 4
|
||||
then
|
||||
liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
|
||||
else
|
||||
return $ Nothing : acc
|
||||
)
|
||||
(map Just redHaskelloids) ([0..1] :: [Int])
|
||||
liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
|
||||
if not $ null newHaskelloids
|
||||
then
|
||||
liftIO $ gegl_node_link
|
||||
(last $ map hFlange newHaskelloids)
|
||||
(nodeGraph ud M.! KeyHNop)
|
||||
else do
|
||||
liftIO $ traceIO "YOU WON!"
|
||||
liftIO $ gegl_node_link
|
||||
(nodeGraph ud M.! KeyWon)
|
||||
(nodeGraph ud M.! KeyFGNop)
|
||||
putAffection ud
|
||||
{ wonlost = True
|
||||
}
|
||||
putAffection ud
|
||||
{ haskelloids = newHaskelloids
|
||||
}
|
||||
|
||||
-- updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
|
||||
-- updateHaskelloid sec h@Haskelloid{..} = do
|
||||
-- let newX = (fst $ hPos) + sec * (fst $ hVel)
|
||||
-- newY = (snd $ hPos) + sec * (snd $ hVel)
|
||||
-- rawRot = hRot + hPitch * sec
|
||||
-- newRot
|
||||
-- | rawRot > 180 = rawRot - 360
|
||||
-- | rawRot < -180 = rawRot + 360
|
||||
-- | otherwise = rawRot
|
||||
-- (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
|
||||
-- liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
|
||||
-- [ Property "x" $ PropertyDouble $ nnx
|
||||
-- , Property "y" $ PropertyDouble $ nny
|
||||
-- ]
|
||||
-- liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
|
||||
-- [ Property "degrees" $ PropertyDouble newRot
|
||||
-- ]
|
||||
-- ud <- getAffection
|
||||
-- lost <- liftIO $ gegl_rectangle_intersect
|
||||
-- (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
|
||||
-- (GeglRectangle
|
||||
-- (floor $ fst $ sPos $ ship ud)
|
||||
-- (floor $ snd $ sPos $ ship ud)
|
||||
-- 50
|
||||
-- 50
|
||||
-- )
|
||||
-- maybe (return ()) (\_ ->
|
||||
-- lose
|
||||
-- ) lost
|
||||
-- return h
|
||||
-- { hPos = (nnx, nny)
|
||||
-- , hRot = newRot
|
||||
-- }
|
||||
|
||||
lose :: Affection UserData ()
|
||||
lose = do
|
||||
ud <- getAffection
|
||||
liftIO $ traceIO "YOU LOST!"
|
||||
_ <- liftIO $ gegl_node_link
|
||||
(nodeGraph ud M.! KeyLost)
|
||||
(nodeGraph ud M.! KeyFGNop)
|
||||
putAffection ud
|
||||
{ wonlost = True
|
||||
}
|
||||
_ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
|
||||
return ()
|
||||
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)
|
||||
|
|
|
|||
65
src/Menu.hs
65
src/Menu.hs
|
|
@ -7,13 +7,68 @@ import Debug.Trace
|
|||
|
||||
import Types
|
||||
|
||||
handleMenuEvent :: Double -> SDL.Event -> Affection UserData ()
|
||||
handleMenuEvent sec e = do
|
||||
ad <- get
|
||||
case SDL.eventPayload e of
|
||||
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
|
||||
traceM "seeya!"
|
||||
ad <- get
|
||||
put ad
|
||||
{ quitEvent = True
|
||||
}
|
||||
_ -> return ()
|
||||
|
||||
loadMenu :: Affection UserData ()
|
||||
loadMenu = do
|
||||
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"
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, fade = FadeIn 1
|
||||
, state = Menu
|
||||
, shots = (shots ud)
|
||||
{ partSysParts = ParticleStorage Nothing [] }
|
||||
}
|
||||
|
||||
updateMenu :: Double -> Affection UserData ()
|
||||
updateMenu sec = do
|
||||
ud <- getAffection
|
||||
nhs <- mapM (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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
module StateMachine where
|
||||
|
||||
import Affection hiding (StateMachine(..))
|
||||
import Affection
|
||||
import qualified SDL
|
||||
import GEGL
|
||||
|
||||
|
|
@ -16,91 +16,21 @@ import System.Random (randomRIO)
|
|||
import Types
|
||||
import Commons
|
||||
import InGame
|
||||
|
||||
class StateMachine a us where
|
||||
smLoad :: a -> Affection us ()
|
||||
smUpdate :: a -> Double -> Affection us ()
|
||||
smEvent :: a -> Double -> SDL.Event -> Affection us ()
|
||||
smDraw :: a -> Affection us ()
|
||||
smClean :: a -> Affection us ()
|
||||
import Menu
|
||||
|
||||
instance StateMachine State UserData where
|
||||
smLoad Menu = do
|
||||
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"
|
||||
putAffection ud
|
||||
{ haskelloids = hs
|
||||
, fade = FadeIn 1
|
||||
, state = Menu
|
||||
, shots = (shots ud)
|
||||
{ partSysParts = ParticleStorage Nothing [] }
|
||||
}
|
||||
smLoad Menu = loadMenu
|
||||
|
||||
smLoad InGame = loadGame
|
||||
|
||||
smUpdate Menu sec = do
|
||||
ud <- getAffection
|
||||
nhs <- mapM (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
|
||||
}
|
||||
smUpdate Menu = updateMenu
|
||||
|
||||
smUpdate InGame sec = updateGame sec
|
||||
|
||||
smEvent Menu _ e = do
|
||||
ad <- get
|
||||
case SDL.eventPayload 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 _ ->
|
||||
put ad
|
||||
{ quitEvent = True
|
||||
}
|
||||
_ -> return ()
|
||||
smEvent Menu = handleMenuEvent
|
||||
|
||||
-- smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e
|
||||
smEvent InGame _ e = handleGameEvent (SDL.eventPayload e)
|
||||
smEvent InGame = handleGameEvent
|
||||
|
||||
smDraw Menu = do
|
||||
ud <- getAffection
|
||||
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
|
||||
present
|
||||
(GeglRectangle 0 0 800 600)
|
||||
(buffer ud)
|
||||
True
|
||||
smDraw Menu = return ()
|
||||
|
||||
smDraw InGame = drawGame
|
||||
|
|
|
|||
55
src/Types.hs
55
src/Types.hs
|
|
@ -2,64 +2,38 @@
|
|||
|
||||
module Types where
|
||||
|
||||
import Affection hiding (StateMachine)
|
||||
import Affection
|
||||
import qualified SDL
|
||||
import GEGL
|
||||
import qualified Data.Map as M
|
||||
import NanoVG
|
||||
|
||||
data UserData = UserData
|
||||
{ nodeGraph :: M.Map NodeKey GeglNode
|
||||
, ship :: Ship
|
||||
, buffer :: GeglBuffer
|
||||
{ ship :: Ship
|
||||
, haskelloids :: [Haskelloid]
|
||||
, shots :: ParticleSystem
|
||||
-- , shots :: ParticleSystem
|
||||
-- , debris :: ParticleSystem
|
||||
, wonlost :: Bool
|
||||
, wonlost :: Maybe WonLost
|
||||
, pixelSize :: Int
|
||||
, state :: State
|
||||
, fade :: MenuFade
|
||||
, neno :: Context
|
||||
}
|
||||
|
||||
data Ship = Ship
|
||||
{ sPos :: (Double, Double)
|
||||
, sVel :: (Double, Double)
|
||||
{ sPos :: V2 Double
|
||||
, sVel :: V2 Double
|
||||
, sRot :: Double
|
||||
, sFlange :: GeglNode
|
||||
, sImg :: Image
|
||||
}
|
||||
|
||||
data Haskelloid = Haskelloid
|
||||
{ hPos :: (Double, Double)
|
||||
, hVel :: (Double, Double)
|
||||
{ hPos :: V2 Double
|
||||
, hVel :: V2 Double
|
||||
, hRot :: Double
|
||||
, hPitch :: Double
|
||||
, hDiv :: Int
|
||||
, hFlange :: GeglNode
|
||||
, hNodeGraph :: M.Map String GeglNode
|
||||
, hImg :: Image
|
||||
} deriving (Eq)
|
||||
|
||||
data NodeKey
|
||||
= KeyRoot
|
||||
| KeyShip
|
||||
| KeyShipTranslate
|
||||
| KeyShipRotate
|
||||
| KeyPNop
|
||||
| KeyHNop
|
||||
| KeyCrop
|
||||
| KeyShipOver
|
||||
| KeySink
|
||||
| KeyWon
|
||||
| KeyLost
|
||||
| KeyPixelize
|
||||
| KeyFGOver
|
||||
| KeyFGNop
|
||||
| KeyFGTrans
|
||||
| KeyMenuHeading
|
||||
| KeyMenuText
|
||||
| KeyMenuStart
|
||||
| KeyMenuHighscore
|
||||
| KeyMenuOver
|
||||
deriving (Ord, Eq)
|
||||
|
||||
data State
|
||||
= Menu
|
||||
| HighScore
|
||||
|
|
@ -68,3 +42,8 @@ data State
|
|||
data MenuFade
|
||||
= FadeIn Double
|
||||
| FadeOut Double
|
||||
|
||||
data WonLost
|
||||
= Won
|
||||
| Lost
|
||||
deriving (Eq)
|
||||
|
|
|
|||
Loading…
Reference in a new issue