doesn't work
This commit is contained in:
nek0
parent
664dc8f870
commit
25d45277a0
3 changed files with 134 additions and 133 deletions
|
|
@ -110,7 +110,8 @@ updateGame sec = do
|
||||||
}
|
}
|
||||||
-- liftIO $ traceIO $ show $ length nhs
|
-- liftIO $ traceIO $ show $ length nhs
|
||||||
ud3 <- getAffection
|
ud3 <- getAffection
|
||||||
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
-- ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
|
||||||
|
ups <- updateParticleSystem (shots ud3) sec shotsUpd
|
||||||
ud4 <- getAffection
|
ud4 <- getAffection
|
||||||
putAffection ud4
|
putAffection ud4
|
||||||
{ shots = ups
|
{ shots = ups
|
||||||
|
|
|
||||||
259
src/Main.hs
259
src/Main.hs
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Affection
|
import Affection hiding (StateMachine(..))
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
import GEGL
|
import GEGL
|
||||||
|
|
||||||
|
|
@ -39,108 +39,107 @@ main = withAffection AffectionConfig
|
||||||
|
|
||||||
update :: Double -> Affection UserData ()
|
update :: Double -> Affection UserData ()
|
||||||
update sec = do
|
update sec = do
|
||||||
-- traceM $ (show $ 1 / sec) ++ " FPS"
|
ud <- getAffection
|
||||||
ad <- get
|
smUpdate (state ud) sec
|
||||||
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.! 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
|
|
||||||
}
|
|
||||||
|
|
||||||
update :: Double -> [SDL.Event] -> Affection UserData ()
|
-- update sec = do
|
||||||
update sec evs = do
|
-- -- traceM $ (show $ 1 / sec) ++ " FPS"
|
||||||
wd <- getAffection
|
-- ad <- get
|
||||||
smUpdate (state wd) sec
|
-- wd <- getAffection
|
||||||
mapM_ (smEvent (state wd) sec) evs
|
-- 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
|
||||||
|
-- }
|
||||||
|
|
||||||
draw :: Affection UserData ()
|
draw :: Affection UserData ()
|
||||||
draw = do
|
draw = do
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
drawParticleSystem (shots ud) (\_ _ _ -> return())
|
smDraw (state ud)
|
||||||
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
|
-- drawParticleSystem (shots ud) (\_ _ _ -> return())
|
||||||
present
|
-- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
|
||||||
(GeglRectangle 0 0 800 600)
|
-- present
|
||||||
(buffer ud)
|
-- (GeglRectangle 0 0 800 600)
|
||||||
True
|
-- (buffer ud)
|
||||||
render Nothing Nothing
|
-- True
|
||||||
|
-- render Nothing Nothing
|
||||||
|
|
||||||
shotsUpd :: Double -> Particle -> Affection UserData Particle
|
-- shotsUpd :: Double -> Particle -> Affection UserData Particle
|
||||||
shotsUpd sec part@Particle{..} = do
|
-- shotsUpd sec part@Particle{..} = do
|
||||||
let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
|
-- let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
|
||||||
newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
|
-- newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
|
||||||
(nnx, nny) = wrapAround (newX, newY) 4
|
-- (nnx, nny) = wrapAround (newX, newY) 4
|
||||||
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
|
-- liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
|
||||||
[ Property "x" $ PropertyDouble $ nnx
|
-- [ Property "x" $ PropertyDouble $ nnx
|
||||||
, Property "y" $ PropertyDouble $ nny
|
-- , Property "y" $ PropertyDouble $ nny
|
||||||
]
|
-- ]
|
||||||
ud <- getAffection
|
-- ud <- getAffection
|
||||||
inters <- catMaybes <$> mapM (\h -> do
|
-- inters <- catMaybes <$> mapM (\h -> do
|
||||||
col <- liftIO $ gegl_rectangle_intersect
|
-- col <- liftIO $ gegl_rectangle_intersect
|
||||||
(GeglRectangle (floor nnx) (floor nny) 4 4)
|
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||||
(GeglRectangle
|
-- (GeglRectangle
|
||||||
(floor $ fst $ hPos h)
|
-- (floor $ fst $ hPos h)
|
||||||
(floor $ snd $ hPos h)
|
-- (floor $ snd $ hPos h)
|
||||||
(100 `div` hDiv h)
|
-- (100 `div` hDiv h)
|
||||||
(100 `div` hDiv h)
|
-- (100 `div` hDiv h)
|
||||||
)
|
-- )
|
||||||
case col of
|
-- case col of
|
||||||
Just _ -> return $ Just h
|
-- Just _ -> return $ Just h
|
||||||
Nothing -> return Nothing
|
-- Nothing -> return Nothing
|
||||||
) (haskelloids ud)
|
-- ) (haskelloids ud)
|
||||||
when (not $ null inters) $
|
-- when (not $ null inters) $
|
||||||
haskelloidShotDown $ head inters
|
-- haskelloidShotDown $ head inters
|
||||||
lost <- liftIO $ gegl_rectangle_intersect
|
-- lost <- liftIO $ gegl_rectangle_intersect
|
||||||
(GeglRectangle (floor nnx) (floor nny) 4 4)
|
-- (GeglRectangle (floor nnx) (floor nny) 4 4)
|
||||||
(GeglRectangle
|
-- (GeglRectangle
|
||||||
(floor $ fst $ sPos $ ship ud)
|
-- (floor $ fst $ sPos $ ship ud)
|
||||||
(floor $ snd $ sPos $ ship ud)
|
-- (floor $ snd $ sPos $ ship ud)
|
||||||
50
|
-- 50
|
||||||
50
|
-- 50
|
||||||
)
|
-- )
|
||||||
maybe (return ()) (\_ ->
|
-- maybe (return ()) (\_ ->
|
||||||
lose
|
-- lose
|
||||||
) lost
|
-- ) lost
|
||||||
return part
|
-- return part
|
||||||
{ particlePosition = (nnx, nny)
|
-- { particlePosition = (nnx, nny)
|
||||||
, particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
|
-- , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
|
||||||
}
|
-- }
|
||||||
|
|
||||||
haskelloidShotDown :: Haskelloid -> Affection UserData ()
|
haskelloidShotDown :: Haskelloid -> Affection UserData ()
|
||||||
haskelloidShotDown h = do
|
haskelloidShotDown h = do
|
||||||
|
|
@ -175,39 +174,39 @@ haskelloidShotDown h = do
|
||||||
{ haskelloids = newHaskelloids
|
{ haskelloids = newHaskelloids
|
||||||
}
|
}
|
||||||
|
|
||||||
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
|
-- updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
|
||||||
updateHaskelloid sec h@Haskelloid{..} = do
|
-- updateHaskelloid sec h@Haskelloid{..} = do
|
||||||
let newX = (fst $ hPos) + sec * (fst $ hVel)
|
-- let newX = (fst $ hPos) + sec * (fst $ hVel)
|
||||||
newY = (snd $ hPos) + sec * (snd $ hVel)
|
-- newY = (snd $ hPos) + sec * (snd $ hVel)
|
||||||
rawRot = hRot + hPitch * sec
|
-- rawRot = hRot + hPitch * sec
|
||||||
newRot
|
-- newRot
|
||||||
| rawRot > 360 = rawRot - 360
|
-- | rawRot > 180 = rawRot - 360
|
||||||
| rawRot < -360 = rawRot + 360
|
-- | rawRot < -180 = rawRot + 360
|
||||||
| otherwise = rawRot
|
-- | otherwise = rawRot
|
||||||
(nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
|
-- (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
|
||||||
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
|
-- liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
|
||||||
[ Property "x" $ PropertyDouble $ nnx
|
-- [ Property "x" $ PropertyDouble $ nnx
|
||||||
, Property "y" $ PropertyDouble $ nny
|
-- , Property "y" $ PropertyDouble $ nny
|
||||||
]
|
-- ]
|
||||||
liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
|
-- liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
|
||||||
[ Property "degrees" $ PropertyDouble newRot
|
-- [ Property "degrees" $ PropertyDouble newRot
|
||||||
]
|
-- ]
|
||||||
ud <- getAffection
|
-- ud <- getAffection
|
||||||
lost <- liftIO $ gegl_rectangle_intersect
|
-- lost <- liftIO $ gegl_rectangle_intersect
|
||||||
(GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
|
-- (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
|
||||||
(GeglRectangle
|
-- (GeglRectangle
|
||||||
(floor $ fst $ sPos $ ship ud)
|
-- (floor $ fst $ sPos $ ship ud)
|
||||||
(floor $ snd $ sPos $ ship ud)
|
-- (floor $ snd $ sPos $ ship ud)
|
||||||
50
|
-- 50
|
||||||
50
|
-- 50
|
||||||
)
|
-- )
|
||||||
maybe (return ()) (\_ ->
|
-- maybe (return ()) (\_ ->
|
||||||
lose
|
-- lose
|
||||||
) lost
|
-- ) lost
|
||||||
return h
|
-- return h
|
||||||
{ hPos = (nnx, nny)
|
-- { hPos = (nnx, nny)
|
||||||
, hRot = newRot
|
-- , hRot = newRot
|
||||||
}
|
-- }
|
||||||
|
|
||||||
lose :: Affection UserData ()
|
lose :: Affection UserData ()
|
||||||
lose = do
|
lose = do
|
||||||
|
|
|
||||||
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
module StateMachine where
|
module StateMachine where
|
||||||
|
|
||||||
import Affection
|
import Affection hiding (StateMachine(..))
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
import GEGL
|
import GEGL
|
||||||
|
|
||||||
|
|
@ -92,7 +92,8 @@ instance StateMachine State UserData where
|
||||||
}
|
}
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
|
|
||||||
smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e
|
-- smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e
|
||||||
|
smEvent InGame _ e = handleGameEvent (SDL.eventPayload e)
|
||||||
|
|
||||||
smDraw Menu = do
|
smDraw Menu = do
|
||||||
ud <- getAffection
|
ud <- getAffection
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue