works halfway as intended
This commit is contained in:
nek0
parent
eae27cbe15
commit
a1c6ce6b92
4 changed files with 404 additions and 175 deletions
148
src/Commons.hs
148
src/Commons.hs
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
336
src/Main.hs
336
src/Main.hs
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -39,9 +39,9 @@ data Haskelloid = Haskelloid
|
|||
|
||||
data NodeKey
|
||||
= KeyRoot
|
||||
| KeyTranslate
|
||||
| KeyRotate
|
||||
| KeyShip
|
||||
| KeyShipTranslate
|
||||
| KeyShipRotate
|
||||
| KeyPNop
|
||||
| KeyHNop
|
||||
| KeyCrop
|
||||
|
|
|
|||
Loading…
Reference in a new issue