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
|
|
|
|
|
2016-12-28 18:13:39 +00:00
|
|
|
import Data.List (delete)
|
2016-12-27 22:25:58 +00:00
|
|
|
import qualified Data.Map as M
|
2016-12-28 18:13:39 +00:00
|
|
|
import Data.Maybe (catMaybes)
|
2016-12-27 22:25:58 +00:00
|
|
|
|
2016-12-28 18:13:39 +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
|
2016-12-28 18:13:39 +00:00
|
|
|
-- 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 ()
|