diff --git a/.gitignore b/.gitignore index 05d4d64..c720a2c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,8 @@ .cabal-sandbox/ cabal.sandbox.config dist/ +*.prof +*.aux +*.hp +*.ps +*.swp diff --git a/assets/Modulo.ttf b/assets/Modulo.ttf new file mode 100644 index 0000000..cfed4fc Binary files /dev/null and b/assets/Modulo.ttf differ diff --git a/assets/haskelloid.png b/assets/haskelloid.png new file mode 100644 index 0000000..a4b7813 Binary files /dev/null and b/assets/haskelloid.png differ diff --git a/assets/haskelloid.svg b/assets/haskelloid.svg index e03949b..33da05d 100644 --- a/assets/haskelloid.svg +++ b/assets/haskelloid.svg @@ -1,16 +1,80 @@ - - - - - - - - - - - - - - - - \ No newline at end of file + + + + + + image/svg+xml + + + + + + + + + + + + + + + diff --git a/assets/ship.png b/assets/ship.png new file mode 100644 index 0000000..d247a53 Binary files /dev/null and b/assets/ship.png differ diff --git a/cabal.config b/cabal.config new file mode 100644 index 0000000..2544e4b --- /dev/null +++ b/cabal.config @@ -0,0 +1 @@ +constraints: affection +debug diff --git a/haskelloids.cabal b/haskelloids.cabal index 504b840..6a72335 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -51,23 +51,31 @@ executable haskelloids -- .hs or .lhs file containing the Main module. main-is: Main.hs ghc-options: -Wall + extra-libraries: GLEW -- Modules included in this executable, other than Main. - other-modules: InGame - , Types + other-modules: Types , Commons + , StateMachine + , Menu + , InGame + , Init + default-extensions: OverloadedStrings -- LANGUAGE extensions used by modules in this package. -- other-extensions: -- Other library packages from which modules are imported. build-depends: base >=4.9 && <4.11 - , affection - , gegl - , babl - , sdl2 + , affection <= 0.0.0.7 + , sdl2 >= 2.1.3.1 + , OpenGL + , containers , random + , linear + , stm + , nanovg -- Directories containing source files. hs-source-dirs: src diff --git a/src/Commons.hs b/src/Commons.hs index 286c0b7..ba9a293 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -1,192 +1,122 @@ +{-# LANGUAGE RecordWildCards #-} + module Commons where import Affection import qualified SDL -import GEGL -import BABL import qualified Data.Map as M -import Data.Maybe (catMaybes) +import Data.List (delete) +import Data.Maybe (catMaybes, isJust) -import Control.Monad (foldM) +import Control.Monad (foldM, unless, when) +import Control.Monad.IO.Class (liftIO) import System.Random (randomRIO) -import Debug.Trace +import NanoVG as N hiding (V2(..)) + +import Linear as L hiding (rotate) + +import Foreign.C.Types (CFloat(..)) import Types toR :: Double -> Double toR deg = deg * pi / 180 -clean :: UserData -> IO () -clean ud = do - mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) - gegl_node_drop $ nodeGraph ud M.! KeyRoot +wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t +wrapAround (V2 nx ny) width = (V2 nnx nny) + where + nnx + | nx > 800 + half = nx - (800 + width) + | nx < -half = nx + 800 + width + | otherwise = nx + nny + | ny > 600 + half = ny - (600 + width) + | ny < -half = ny + 600 + width + | otherwise = ny + half = width / 2 -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 - ] - ship <- 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 - ] - buffer <- 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 buffer - ] - 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" - 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 - -- ] - gegl_node_link_many [ship, 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" - traceM "nodes complete" - myMap <- return $ M.fromList - [ (KeyRoot, root) - , (KeyTranslate, translate) - , (KeyRotate, rotate) - , (KeyShip, ship) - , (KeyPNop, pnop) - , (KeyHNop, hnop) - , (KeyCrop, crop) - , (KeyShipOver, sover) - , (KeySink, sink) - , (KeyWon, won) - , (KeyLost, lost) - , (KeyPixelize, pixelize) - , (KeyFGOver, fgover) - , (KeyFGNop, fgnop) - ] - hs <- catMaybes <$> foldM (\acc _ -> do - px <- liftIO $ randomRIO (0, 800) - py <- liftIO $ 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) hnop - return $ UserData - { nodeGraph = myMap - , ship = Ship - { sPos = (375, 275) - , sVel = (0, 0) - , sRot = 0 - , sFlange = rotate - } - , buffer = buffer - , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer - , haskelloids = hs - , wonlost = False - , pixelSize = 3 - , state = InGame +newHaskelloids :: Affection UserData [Haskelloid] +newHaskelloids = do + img <- haskImage <$> getAffection + liftIO $ mapM (\_ -> do + posx <- randomRIO (0, 800) + posy <- randomRIO (0, 600) + velx <- randomRIO (-10, 10) + vely <- randomRIO (-10, 10) + rot <- randomRIO (-180, 180) + 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 dsec has = + has + { hPos = wrapAround + (hPos has + hVel has * V2 sec sec) + (100 / fromIntegral (hDiv has)) + , hRot = hRot has + hPitch has * sec } + where + sec = realToFrac dsec -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 (0, 360) - pitch <- liftIO $ randomRIO (-45, 45) - tempRoot <- liftIO $ gegl_node_new - tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation - tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" - [ Property "path" $ PropertyString "assets/haskelloid.svg" - , Property "width" $ PropertyInt (100 `div` rdiv) - , Property "height" $ PropertyInt (100 `div` rdiv) - ] - 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 - ] - 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 $ gegl_node_link_many [tempSvg, 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 +clamp :: Ord a => a -> a -> a -> a +clamp a' low up + | a' < low = low + | a' > up = up + | otherwise = a' + +drawImage :: Context -> Image -> V2 Float -> V2 Float -> Float -> Float -> IO () +drawImage ctx img pos dim rot alpha = do + let (V2 x y) = fmap CFloat pos + (V2 w h) = fmap CFloat dim + save ctx + translate ctx (x + (w/2)) (y + (h/2)) + rotate ctx (degToRad $ CFloat rot) + translate ctx (-(w/2)) (-(h/2)) + sPaint <- imagePattern ctx 0 0 w h 0 img (CFloat alpha) + beginPath ctx + rect ctx 0 0 w h + fillPaint ctx sPaint + fill ctx + resetTransform ctx + restore ctx + +drawSpinner :: Context -> Float -> Float -> Float -> Float -> IO () +drawSpinner ctx x y cr ct = do + let a0 = 0+t*6 + a1 = pi + t*6 + r0 = r + r1 = r*0.75 + (cx, cy) = (CFloat x, CFloat y) + r = CFloat cr + t = CFloat ct + save ctx + beginPath ctx + arc ctx cx cy r0 a0 a1 CW + arc ctx cx cy r1 a1 a0 CCW + closePath ctx + let ax = cx+cos a0 * (r0+r1)*0.5 + ay = cy+sin a0 * (r0+r1)*0.5 + bx = cx+cos a1 * (r0+r1)*0.5 + by = cy+sin a1 * (r0+r1)*0.5 + paint <- linearGradient ctx ax ay bx by (rgba 255 255 255 0) (rgba 255 255 255 128) + fillPaint ctx paint + fill ctx + restore ctx + +drawHaskelloid :: Haskelloid -> Affection UserData () +drawHaskelloid (Haskelloid pos _ rot _ div img) = do + ctx <- nano <$> getAffection + liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255 + where + dim = (fmap (/ fromIntegral div) (V2 100 100)) diff --git a/src/InGame.hs b/src/InGame.hs index 5dae5ad..1eefe50 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -1,109 +1,257 @@ +{-# LANGUAGE RecordWildCards #-} module InGame where -import Affection +import Affection as A import qualified SDL -import GEGL -import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe (isNothing, catMaybes) -import Control.Monad (when) +import Control.Monad (when, unless) +import Control.Monad.IO.Class (liftIO) -import Debug.Trace +import System.Random (randomRIO) + +import Linear + +import NanoVG hiding (V2(..)) + +import Foreign.C.Types (CFloat(..)) import Types import Commons -handleGameEvent :: SDL.EventPayload -> Affection UserData () -handleGameEvent e = do - ad <- get - wd <- getAffection - sec <- getDelta - case e of - SDL.KeyboardEvent dat -> - 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) + 270 * sec - } - } - SDL.KeycodeRight -> do - ud <- getAffection - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ - putAffection ud - { ship = (ship ud) - { sRot = (sRot $ ship ud) - 270 * sec - } - } - 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) - } - } - -- 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) + (fst $ sVel $ ship ud))) - -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud))) - ( (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 - } - SDL.KeycodeR -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do - liftIO $ traceIO "reloading" - liftIO $ clean wd - nd <- liftIO $ load - putAffection nd - _ -> return () - SDL.WindowClosedEvent _ -> do - traceM "seeya!" - put ad - { quitEvent = True - } +dVel :: Float +dVel = 100 + +pewVel :: Float +pewVel = 200 + +pewTTL :: Double +pewTTL = 10 + +dRot :: Float +dRot = 150 + +loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData () +loadGame stateChange clean = do + liftIO $ logIO A.Debug "loading game" + ud <- getAffection + nhs <- newHaskelloids + kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean) + putAffection ud + { stateUUIDs = UUIDClean [] [kid] + , haskelloids = nhs + , ship = (ship ud) + { sPos = V2 400 300 + , sVel = V2 0 0 + , sRot = 0 + } + , shots = [] + , state = InGame + , wonlost = Nothing + } + +handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData () +handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $ + case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do + liftIO $ logIO A.Debug "PEW!" + shoot + SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do + ud <- getAffection + unless (isNothing $ wonlost ud) $ do + liftIO $ logIO A.Debug "Reloading" + clean + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "Leave to Menu" + stateChange + SDL.KeycodeW -> accelShip dVel + SDL.KeycodeS -> accelShip (-dVel) + SDL.KeycodeA -> rotateShip dRot + SDL.KeycodeD -> rotateShip (-dRot) _ -> return () + +shoot :: Affection UserData () +shoot = do + ud <- getAffection + let Ship{..} = ship ud + npew = Pew ppos pVel pewTTL + ppos = sPos + ((V2 0 25) `rotVec` sRot) + pVel = sVel + ((V2 0 pewVel) `rotVec` sRot) + putAffection ud + { shots = npew : shots ud + } + +accelShip :: Float -> Affection UserData () +accelShip vel = do + ud <- getAffection + dt <- getDelta + let s = ship ud + nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s) + putAffection ud + { ship = s + { sVel = nVel + } + } + +rotateShip :: Float -> Affection UserData () +rotateShip deg = do + ud <- getAffection + dt <- getDelta + putAffection ud + { ship = (ship ud) + { sRot = (sRot $ ship ud) - deg * realToFrac dt + } + } + +rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a +rotVec (V2 x y) deg = V2 nx ny + where + nx = x * (cos $ dtor deg) + y * (sin $ dtor deg) + ny = x * (sin $ dtor deg) - y * (cos $ dtor deg) + dtor = (pi / 180 *) + +updateGame :: Double -> Affection UserData () +updateGame sec = do + ud <- getAffection + let nhs = map (updateHaskelloid sec) (haskelloids ud) + npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud) + putAffection ud + { haskelloids = nhs + , shots = npews + , ship = updateShip sec (ship ud) + } + checkShotDown + ud2 <- getAffection + when + ( ( any (checkCollision (ship ud2)) (haskelloids ud2) + || any (checkFriendlyFire (ship ud2)) (shots ud2) + ) + && isNothing (wonlost ud2) + ) + (putAffection ud2 + { wonlost = Just Lost + } + ) + when (isNothing (wonlost ud2) && null (haskelloids ud2)) + (putAffection ud2 + { wonlost = Just Won + } + ) + +checkShotDown :: Affection UserData () +checkShotDown = + do + ud <- getAffection + let shoots = shots ud + hasks = haskelloids ud + pairs = catMaybes $ concatMap (crossOut hasks) shoots + deadHasks = map fst pairs + nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks + npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (map snd pairs) + children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do + n1velx <- randomRIO (-10, 10) + n1vely <- randomRIO (-10, 10) + n1rot <- randomRIO (-180, 180) + n1pitch <- randomRIO (-pi, pi) + n2velx <- randomRIO (-10, 10) + n2vely <- randomRIO (-10, 10) + n2rot <- randomRIO (-180, 180) + n2pitch <- randomRIO (-pi, pi) + let ndiv = hDiv + 1 + if ndiv > 5 + then return [] + else return $ + [ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg + , Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg + ] + ) deadHasks + putAffection ud + { shots = npews + , haskelloids = nhask ++ children + } + where + crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)] + crossOut hs p = + foldl (\acc h -> + if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h)) + then Just (h, p) : acc + else Nothing : acc + ) [] hs + +checkCollision :: Ship -> Haskelloid -> Bool +checkCollision s h = + distance (sPos s) (hPos h) < minDist + where + minDist = 20 + (50 / fromIntegral (hDiv h)) + +checkFriendlyFire :: Ship -> Pew -> Bool +checkFriendlyFire s p = + distance (sPos s) (pPos p) < 20 + +updateShip :: Double -> Ship -> Ship +updateShip ddt s@Ship{..} = s + { sPos = wrapAround (sPos + fmap (dt *) sVel) 40 + } + where + dt = realToFrac ddt + +updatePew :: Double -> Pew -> Pew +updatePew ddt p@Pew{..} = p + { pPos = wrapAround (pPos + fmap (dt *) pVel) 0 + , pTTL = pTTL - ddt + } + where + dt = realToFrac ddt + +drawGame :: Affection UserData () +drawGame = do + ud <- getAffection + mapM_ drawHaskelloid (haskelloids ud) + mapM_ drawPew (shots ud) + case wonlost ud of + Just Lost -> liftIO $ do + let ctx = nano ud + save ctx + fontSize ctx 120 + fontFace ctx "modulo" + textAlign ctx (S.fromList [AlignCenter,AlignTop]) + fillColor ctx (rgba 255 255 255 255) + textBox ctx 0 200 800 "YOU LOST!" + fillColor ctx (rgba 255 128 0 255) + fontSize ctx 40 + textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again" + restore ctx + Just Won -> liftIO $ do + let ctx = nano ud + save ctx + fontSize ctx 120 + fontFace ctx "modulo" + textAlign ctx (S.fromList [AlignCenter,AlignTop]) + fillColor ctx (rgba 255 255 255 255) + textBox ctx 0 200 800 "YOU WON!" + fillColor ctx (rgba 128 255 0 255) + fontSize ctx 40 + textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again" + restore ctx + Nothing -> drawShip (ship ud) + +drawShip :: Ship -> Affection UserData () +drawShip Ship{..} = do + ctx <- nano <$> getAffection + liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255 + where + dim = V2 40 40 + +drawPew :: Pew -> Affection UserData () +drawPew Pew{..} = do + ctx <- nano <$> getAffection + liftIO $ do + let (V2 x y) = fmap CFloat pPos + save ctx + beginPath ctx + fillColor ctx (rgba 255 128 0 255) + circle ctx x y 2 + fill ctx + restore ctx diff --git a/src/Init.hs b/src/Init.hs new file mode 100644 index 0000000..d377e12 --- /dev/null +++ b/src/Init.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Init where + +import Affection as A + +import SDL (($=)) +import qualified SDL + +import qualified Graphics.Rendering.OpenGL as GL + +import qualified Data.Set as S +import Data.Maybe + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Concurrent.STM + +import System.Random +import System.Exit (exitFailure) + +import Linear + +import NanoVG hiding (V2) + +import Foreign.C.Types (CInt(..)) + +-- Internal imports + +import Types + +foreign import ccall unsafe "glewInit" + glewInit :: IO CInt + +load :: IO UserData +load = do + -- liftIO $ logIO A.Debug "Let's drop some Hints for SDL" + -- SDL.HintRenderDriver $= SDL.OpenGL + liftIO $ logIO A.Debug "init GLEW" + _ <- glewInit + liftIO $ logIO A.Debug "loading state" + liftIO $ logIO A.Debug "create context" + nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes, NanoVG.Debug]) + liftIO $ logIO A.Debug "load ship image" + mshipImage <- createImage nvgCtx (FileName "assets/ship.png") 0 + when (isNothing mshipImage) $ do + logIO Error "Failed to load asset ship" + exitFailure + mhaskImage <- liftIO $ + createImage nvgCtx (FileName "assets/haskelloid.png") 0 + when (isNothing mhaskImage) $ + liftIO $ logIO Error "Failed to load asset haskelloid" + mfont <- createFont nvgCtx "modulo" (FileName "assets/Modulo.ttf") + when (isNothing mfont) $ do + logIO Error "Failed to load font" + exitFailure + liftIO $ logIO A.Debug "Initializing subsystems" + subs <- Subsystems + <$> (return . Window =<< newTVarIO []) + <*> (return . Keyboard =<< newTVarIO []) + liftIO $ logIO A.Debug "Setting viewport" + GL.viewport $= (GL.Position 0 0, GL.Size 800 600) + liftIO $ logIO A.Debug "Returning UserData" + return UserData + { ship = Ship + { sPos = V2 400 300 + , sVel = V2 0 0 + , sRot = 0 + , sImg = fromJust mshipImage + } + , haskelloids = [] + , shots = [] + , wonlost = Nothing + , state = Menu + , fade = FadeIn 1 + , nano = nvgCtx + , font = fromJust mfont + , subsystems = subs + , haskImage = fromJust mhaskImage + } diff --git a/src/Main.hs b/src/Main.hs index 4ad41c6..41171b4 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,233 +1,87 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Main where -import Affection +import Affection as A +import SDL (($=)) import qualified SDL -import GEGL +import qualified Graphics.Rendering.OpenGL as GL -import Data.List (delete) import qualified Data.Map as M -import Data.Maybe (catMaybes) -import Control.Monad (when, foldM) +import Linear as L -import Debug.Trace +import NanoVG hiding (V2(..), V4(..)) + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) -- internal imports import Types -import InGame import Commons +import StateMachine () +import Init main :: IO () -main = withAffection $ AffectionConfig - { initComponents = All - , windowTitle = "Haskelloids" - , windowConfig = defaultWindow - , preLoop = return () - , drawLoop = draw - , updateLoop = update - , loadState = load - , cleanUp = clean - , canvasSize = Nothing - , initScreenMode = SDL.Windowed - , eventLoop = handleGameEvent - } +main = do + logIO A.Debug "Starting" + withAffection AffectionConfig + { initComponents = All + , windowTitle = "Haskelloids" + , windowConfig = SDL.defaultWindow + { SDL.windowOpenGL = Just SDL.defaultOpenGL + { SDL.glProfile = SDL.Core SDL.Normal 3 2 + , SDL.glColorPrecision = V4 8 8 8 1 + } + } + , initScreenMode = SDL.Windowed + , canvasSize = Nothing + , loadState = load + , preLoop = pre >> smLoad Menu + , eventLoop = handle + , updateLoop = update + , drawLoop = draw + , cleanUp = (\_ -> return ()) + } + +pre :: Affection UserData () +pre = do + subs <- subsystems <$> getAffection + liftIO $ logIO A.Debug "Setting global resize event listener" + _ <- partSubscribe (subWindow subs) $ \msg -> case msg of + MsgWindowResize _ _ (V2 w h) -> do + liftIO $ logIO A.Debug "Window has been resized" + let nw = floor $ fromIntegral h * (800/600) + dw = floor $ (fromIntegral w - fromIntegral nw) / 2 + GL.viewport $= (GL.Position dw 0, GL.Size nw h) + _ -> return () + _ <- partSubscribe (subKeyboard subs) $ \kbdev -> + when (msgKbdKeyMotion kbdev == SDL.Pressed) $ + case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeF -> do + dt <- getDelta + liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt) + SDL.KeycodeO -> toggleScreen + _ -> return () + return () update :: Double -> Affection UserData () 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 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.! KeyTranslate) $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble $ nnx - , Property "y" $ PropertyDouble $ nny - ] - liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ 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 - } + ud <- getAffection + smUpdate (state ud) sec -wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) -wrapAround (nx, ny) width = (nnx, nny) - where - nnx = - if nx > 800 - then nx - (800 + width) - else if nx < -width then nx + 800 + width else nx - nny = - if ny > 600 - then ny - (600 + width) - else if ny < -width then ny + 600 + width else ny +handle :: [SDL.EventPayload] -> Affection UserData () +handle e = do + (Subsystems w k) <- subsystems <$> getAffection + _ <- consumeSDLEvents w =<< consumeSDLEvents k e + return () draw :: Affection UserData () draw = do ud <- getAffection - liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink - -- mintr <- liftIO $ gegl_rectangle_intersect - -- (GeglRectangle 0 0 800 600) - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- maybe (return ()) (\intr -> - -- present - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- (buffer ud) - -- False - -- ) mintr - -- XXX: above part crashes regularly for no apparent reason - present - (GeglRectangle 0 0 800 600) - (buffer ud) - True - -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 - } - -shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () -shotsDraw _ _ _ = return () - -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 $ 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 () + -- window <- drawWindow <$> get + -- pf <- liftIO $ SDL.getWindowPixelFormat window + -- liftIO $ logIO A.Debug $ "Window pixel format: " ++ show pf + liftIO $ beginFrame (nano ud) 800 600 1 + smDraw (state ud) + liftIO $ endFrame (nano ud) diff --git a/src/Menu.hs b/src/Menu.hs new file mode 100644 index 0000000..bffa789 --- /dev/null +++ b/src/Menu.hs @@ -0,0 +1,86 @@ +module Menu where + +import Affection as A +import qualified SDL + +import Debug.Trace + +import Data.Maybe +import qualified Data.Set as S + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) + +import qualified Data.Map as M + +import NanoVG hiding (V2(..), V4(..)) + +import Linear + +import Foreign.C.Types + +-- internal imports + +import Types +import Commons + +loadMenu :: (Affection UserData ()) -> Affection UserData () +loadMenu stateChange = do + liftIO $ logIO A.Debug "Loading Menu" + ud <- getAffection + hs <- newHaskelloids + kbdUUID <- partSubscribe (subKeyboard $ subsystems ud) + (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $ + case SDL.keysymKeycode (msgKbdKeysym kbdev) of + SDL.KeycodeEscape -> do + liftIO $ logIO A.Debug "seeya" + quit + SDL.KeycodeSpace -> do + liftIO $ logIO A.Debug "Leaving Menu to Game" + stateChange + _ -> return () + ) + putAffection ud + { haskelloids = hs + , fade = FadeIn 1 + , state = Menu + , stateUUIDs = UUIDClean [] [kbdUUID] + -- , shots = (shots ud) + -- { partSysParts = ParticleStorage Nothing [] } + } + +updateMenu :: Double -> Affection UserData () +updateMenu sec = do + ud <- getAffection + let nhs = map (updateHaskelloid sec) (haskelloids ud) + case fade ud of + FadeIn ttl -> do + putAffection ud + { fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1 + , haskelloids = nhs + } + FadeOut ttl -> do + putAffection ud + { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1 + , haskelloids = nhs + } + +drawMenu :: Affection UserData () +drawMenu = do + ud <- getAffection + mapM_ drawHaskelloid (haskelloids ud) + liftIO $ do + let ctx = nano ud + alpha fio = case fio of + FadeIn d -> (floor (255 * (1 - d))) + FadeOut d -> (floor (255 * d)) + save ctx + fontSize ctx 120 + fontFace ctx "modulo" + textAlign ctx (S.fromList [AlignCenter,AlignTop]) + fillColor ctx (rgba 255 255 255 255) + textBox ctx 0 200 800 "HASKELLOIDS" + fillColor ctx (rgba 0 128 255 (alpha $ fade ud)) + fontSize ctx 40 + textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit" + restore ctx diff --git a/src/StateMachine.hs b/src/StateMachine.hs new file mode 100644 index 0000000..946da7b --- /dev/null +++ b/src/StateMachine.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module StateMachine where + +import Affection + +import Types +import InGame +import Menu + +instance StateMachine State UserData where + smLoad Menu = loadMenu (smClean Menu >> smLoad InGame) + + smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame) + + smUpdate Menu = updateMenu + + smUpdate InGame = updateGame + + smDraw Menu = drawMenu + + smDraw InGame = drawGame + + smEvent _ _ = return () + + smClean _ = do + ud <- getAffection + let (UUIDClean uuwin uukbd) = stateUUIDs ud + (Subsystems win kbd) = subsystems ud + mapM_ (partUnSubscribe win) uuwin + mapM_ (partUnSubscribe kbd) uukbd + putAffection ud + { stateUUIDs = UUIDClean [] [] + } diff --git a/src/Types.hs b/src/Types.hs index b7b37b9..4ec6ede 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,58 +1,115 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Types where import Affection import qualified SDL -import GEGL -import BABL -import qualified Data.Map as M +import NanoVG hiding (V2(..)) +import Linear + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) data UserData = UserData - { nodeGraph :: M.Map NodeKey GeglNode - , ship :: Ship - , buffer :: GeglBuffer + { ship :: Ship , haskelloids :: [Haskelloid] - , shots :: ParticleSystem + , shots :: [Pew] -- , debris :: ParticleSystem - , wonlost :: Bool + , wonlost :: Maybe WonLost , pixelSize :: Int , state :: State + , fade :: MenuFade + , nano :: Context + , font :: Font + , subsystems :: Subsystems + , haskImage :: Image + , stateUUIDs :: UUIDClean } data Ship = Ship - { sPos :: (Double, Double) - , sVel :: (Double, Double) - , sRot :: Double - , sFlange :: GeglNode + { sPos :: V2 Float + , sVel :: V2 Float + , sRot :: Float + , sImg :: Image } -data Haskelloid = Haskelloid - { hPos :: (Double, Double) - , hVel :: (Double, Double) - , hRot :: Double - , hPitch :: Double - , hDiv :: Int - , hFlange :: GeglNode - , hNodeGraph :: M.Map String GeglNode +data Pew = Pew + { pPos :: V2 Float + , pVel :: V2 Float + , pTTL :: Double } deriving (Eq) -data NodeKey - = KeyRoot - | KeyTranslate - | KeyRotate - | KeyShip - | KeyPNop - | KeyHNop - | KeyCrop - | KeyShipOver - | KeySink - | KeyWon - | KeyLost - | KeyPixelize - | KeyFGOver - | KeyFGNop - deriving (Ord, Eq) +data Haskelloid = Haskelloid + { hPos :: V2 Float + , hVel :: V2 Float + , hRot :: Float + , hPitch :: Float + , hDiv :: Int + , hImg :: Image + } deriving (Eq) data State = Menu - | HighScore + -- | HighScore | InGame + +data MenuFade + = FadeIn Double + | FadeOut Double + +data WonLost + = Won + | Lost + deriving (Eq) + +data Subsystems = Subsystems + { subWindow :: Window + , subKeyboard :: Keyboard + } + +data UUIDClean = UUIDClean + { uuWindow :: [MsgId WindowMessage] + , uuKeyboard :: [MsgId KeyboardMessage] + } + +newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())]) + +instance Participant Window WindowMessage UserData where + partSubscribers (Window t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Window t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgWindowEmptyEvent + + partUnSubscribe (Window t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid)) + where + filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p + +instance SDLSubsystem Window UserData where + consumeSDLEvents = consumeSDLWindowEvents + +newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())]) + +instance Participant Keyboard KeyboardMessage UserData where + partSubscribers (Keyboard t) = do + subTups <- liftIO $ readTVarIO t + return $ map snd subTups + + partSubscribe (Keyboard t) funct = do + uuid <- genUUID + liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) + return $ MsgId uuid MsgKeyboardEmptyEvent + + partUnSubscribe (Keyboard t) (MsgId uuid _) = + liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid)) + where + filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool + filterMsg (u, _) p = u /= p + +instance SDLSubsystem Keyboard UserData where + consumeSDLEvents = consumeSDLKeyboardEvents