haskelloids/src/Main.hs

234 lines
7 KiB
Haskell
Raw Normal View History

2016-12-28 11:19:14 +00:00
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
2016-12-26 21:26:25 +00:00
module Main where
2016-12-27 22:25:58 +00:00
import Affection
import qualified SDL
import GEGL
import Data.List (delete)
2016-12-27 22:25:58 +00:00
import qualified Data.Map as M
import Data.Maybe (catMaybes)
2016-12-27 22:25:58 +00:00
import Control.Monad (when, foldM)
2016-12-27 22:25:58 +00:00
import Debug.Trace
2016-12-31 16:01:24 +00:00
-- internal imports
import Types
import Commons
2017-01-02 23:25:34 +00:00
import StateMachine
2016-12-31 16:01:24 +00:00
2017-01-01 21:58:54 +00:00
import Menu
import InGame
2016-12-26 21:26:25 +00:00
main :: IO ()
2016-12-27 22:25:58 +00:00
main = withAffection $ AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = defaultWindow
2017-01-02 22:29:32 +00:00
, preLoop = pre
2016-12-27 22:25:58 +00:00
, drawLoop = draw
, updateLoop = update
, loadState = load
, cleanUp = clean
}
2017-01-02 22:29:32 +00:00
pre :: Affection UserData ()
pre = smLoad Menu
2016-12-27 22:25:58 +00:00
update :: Double -> Affection UserData ()
update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS"
2017-01-03 16:34:37 +00:00
-- ad <- get
2016-12-28 20:06:14 +00:00
wd <- getAffection
2017-01-03 16:34:37 +00:00
-- 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
-- }
2017-01-02 22:29:32 +00:00
-- case state wd of
-- Menu ->
-- updateMenu sec
-- _ -> return ()
smUpdate (state wd) sec
2016-12-31 16:01:24 +00:00
evs <- SDL.pollEvents
2017-01-02 23:25:34 +00:00
-- mapM_ (\e ->
-- case state wd of
-- Menu ->
-- handleMenuEvent sec e
-- InGame ->
-- handleGameEvent sec e
-- _ -> error "not yet implemented"
-- ) evs
mapM_ (smEvent (state wd) sec) evs
2017-01-03 16:34:37 +00:00
-- 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 shotsDraw
-- ud4 <- getAffection
-- putAffection ud4
-- { ship = (ship ud3)
-- { sPos = (nnx, nny)
-- }
-- , shots = ups
-- }
-- 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
2016-12-28 11:19:45 +00:00
2016-12-27 22:25:58 +00:00
draw :: Affection UserData ()
draw = do
ud <- getAffection
2017-01-02 23:25:34 +00:00
smDraw $ state ud
2016-12-27 22:25:58 +00:00
2017-01-03 16:34:37 +00:00
-- 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 <-
-- 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 ()) (\_ ->
-- 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 ()