doesn't work

This commit is contained in:
nek0 2017-11-04 18:13:28 +01:00
parent 664dc8f870
commit 25d45277a0
3 changed files with 134 additions and 133 deletions

View file

@ -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

View file

@ -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

View file

@ -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