works halfway as intended

This commit is contained in:
nek0 2017-01-03 17:34:37 +01:00
parent eae27cbe15
commit a1c6ce6b92
4 changed files with 404 additions and 175 deletions

View file

@ -1,3 +1,5 @@
{-# LANGUAGE RecordWildCards #-}
module Commons where
import Affection
@ -6,8 +8,10 @@ import GEGL
import BABL
import qualified Data.Map as M
import Data.List (delete)
import Data.Maybe (catMaybes)
import Control.Monad (foldM)
import Control.Monad (foldM, when)
import System.Random (randomRIO)
@ -127,14 +131,14 @@ load _ = do
_ <- 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"
_ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
_ <- gegl_node_connect_to fgnop "output" fgover "aux"
traceM "nodes complete"
myMap <- return $ M.fromList
[ (KeyRoot, root)
, (KeyTranslate, translate)
, (KeyRotate, rotate)
, (KeyShip, shipNode)
, (KeyShipTranslate, translate)
, (KeyShipRotate, rotate)
, (KeyPNop, pnop)
, (KeyHNop, hnop)
, (KeyCrop, crop)
@ -222,3 +226,139 @@ insertHaskelloid hasks split (px, py) = do
, ("rot", tempRot)
]
} : hasks
haskelloidShotDown :: Haskelloid -> Affection UserData ()
haskelloidShotDown h = do
ud <- getAffection
-- liftIO $ traceIO $ show $ length $ haskelloids ud
let redHaskelloids = delete h (haskelloids ud)
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_drop $ hNodeGraph h M.! "root"
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
}
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 $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
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
}
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
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
}
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
shotsDraw _ _ _ = return ()
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 ()

View file

@ -5,14 +5,103 @@ import qualified SDL
import GEGL
import qualified Data.Map as M
import Data.Maybe (catMaybes)
import Control.Monad (when)
import Control.Monad (when, foldM)
import System.Random (randomRIO)
import Debug.Trace
import Types
import Commons
loadGame :: Affection UserData ()
loadGame = do
ud <- getAffection
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyShipTranslate)
"output"
(nodeGraph ud M.! KeyShipOver)
"aux"
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
coords <- liftIO excludeShip
insertHaskelloid acc Nothing coords
) [] ([0..9] :: [Int])
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
putAffection ud
{ haskelloids = hs
, wonlost = False
, shots = ParticleSystem
(ParticleStorage Nothing [])
(nodeGraph ud M.! KeyPNop)
(buffer ud)
, ship = Ship
{ sPos = (375, 275)
, sVel = (0, 0)
, sRot = 0
, sFlange = (nodeGraph ud M.! KeyShipRotate)
}
, pixelSize = 3
, state = InGame
}
excludeShip :: IO (Double, Double)
excludeShip = do
px <- randomRIO (0, 800)
py <- randomRIO (0, 600)
inter <- gegl_rectangle_intersect
(GeglRectangle px py 100 100)
(GeglRectangle 350 250 100 100) -- Ship's starting position and size
case inter of
Just _ ->
excludeShip
Nothing ->
return (fromIntegral px, fromIntegral py)
updateGame :: Double -> Affection UserData ()
updateGame sec = do
ad <- get
ud <- getAffection
when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize ud > 3) $ do
pd <- getAffection
liftIO $ gegl_node_set (nodeGraph pd M.! KeyPixelize) $ Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt $ pixelSize pd - 1
, Property "size-y" $ PropertyInt $ pixelSize pd - 1
]
putAffection ud
{ pixelSize = pixelSize ud -1
}
let nx = (fst $ sPos $ ship ud) + (fst $ sVel $ ship ud) * sec
ny = (snd $ sPos $ ship ud) + (snd $ sVel $ ship ud) * sec
(nnx, nny) = wrapAround (nx, ny) 50
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx
, Property "y" $ PropertyDouble $ nny
]
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud
]
td <- getAffection
putAffection td
{ ship = (ship ud)
{ sPos = (nnx, nny)
}
}
ud2 <- getAffection
nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
putAffection ud2
{ haskelloids = nhs
}
liftIO $ traceIO $ show $ length nhs
ud3 <- getAffection
ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
ud4 <- getAffection
putAffection ud4
{ shots = ups
}
handleGameEvent :: Double -> SDL.Event -> Affection UserData ()
handleGameEvent sec e = do
ad <- get

View file

@ -40,17 +40,17 @@ pre = smLoad Menu
update :: Double -> Affection UserData ()
update sec = do
-- traceM $ (show $ 1 / sec) ++ " FPS"
ad <- get
-- 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
}
-- 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
-- }
-- case state wd of
-- Menu ->
-- updateMenu sec
@ -66,168 +66,168 @@ update sec = do
-- _ -> error "not yet implemented"
-- ) evs
mapM_ (smEvent (state wd) sec) 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 shotsDraw
ud4 <- getAffection
putAffection ud4
{ ship = (ship ud3)
{ sPos = (nnx, nny)
}
, shots = ups
}
-- 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
-- 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
draw :: Affection UserData ()
draw = do
ud <- getAffection
smDraw $ state ud
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 ()
-- 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 ()

View file

@ -39,9 +39,9 @@ data Haskelloid = Haskelloid
data NodeKey
= KeyRoot
| KeyTranslate
| KeyRotate
| KeyShip
| KeyShipTranslate
| KeyShipRotate
| KeyPNop
| KeyHNop
| KeyCrop