diff --git a/haskelloids.cabal b/haskelloids.cabal index c6bd651..cde7cbd 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -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 diff --git a/src/Commons.hs b/src/Commons.hs index e1fc90e..84719dc 100644 --- a/src/Commons.hs +++ b/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 - } diff --git a/src/InGame.hs b/src/InGame.hs index d7688cd..5a5979c 100644 --- a/src/InGame.hs +++ b/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!" diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 index 0000000..c52add6 --- /dev/null +++ b/src/Init.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index a026794..b519552 100644 --- a/src/Main.hs +++ b/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) diff --git a/src/Menu.hs b/src/Menu.hs index 6982903..f8bd123 100644 --- a/src/Menu.hs +++ b/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 + } diff --git a/src/StateMachine.hs b/src/StateMachine.hs index bec5000..ee8ce2e 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs index 14bd4c3..4a65d8e 100644 --- a/src/Types.hs +++ b/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)