haskelloids/src/InGame.hs
2017-12-16 11:55:30 +01:00

236 lines
7.7 KiB
Haskell

module InGame where
import Affection
import qualified SDL
import GEGL
import qualified Data.Map as M
import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
import Control.Monad (when, foldM)
import System.Random (randomRIO)
import Debug.Trace
import Types
import Commons
import Menu
loadGame :: Affection UserData ()
loadGame = do
liftIO $ traceIO "loading game"
ud <- getAffection
_ <- liftIO $ gegl_node_connect_to
(nodeGraph ud M.! KeyShipTranslate)
"output"
(nodeGraph ud M.! KeyShipOver)
"aux"
liftIO $ traceIO "nodes connected"
hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
coords <- liftIO excludeShip
insertHaskelloid acc Nothing coords
) [] ([0..9] :: [Int])
liftIO $ traceIO "inserted haskelloids"
liftIO $ gegl_node_link_many $ map hFlange hs
liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
liftIO $ gegl_node_disconnect
(nodeGraph ud M.! KeyFGOver)
"aux"
liftIO $ traceIO "nodes linked"
putAffection ud
{ haskelloids = hs
, wonlost = Nothing
, 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
}
liftIO $ traceIO "game loaded"
present
(GeglRectangle 0 0 800 600)
(buffer ud)
True
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)
ud3 <- getAffection
putAffection ud3
{ haskelloids = nhs
}
ud3 <- getAffection
ups <- updateParticleSystem (shots ud3) sec shotsUpd
ud4 <- getAffection
when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
putAffection ud4
{ shots = ups
}
drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
present
(GeglRectangle 0 0 800 600)
(buffer ud)
True
handleGameEvent :: SDL.EventPayload -> Affection UserData ()
handleGameEvent e = do
ad <- get
wd <- getAffection
sec <- getDelta
case e of
SDL.KeyboardEvent dat ->
case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
&& (isNothing $ wonlost ud)) $ do
let rawRot = (sRot $ ship ud) + 15 * sec
newRot
| rawRot > 360 = rawRot - 360
| rawRot < 0 = rawRot + 360
| otherwise = rawRot
putAffection ud
{ ship = (ship ud)
{ sRot = newRot
}
}
SDL.KeycodeRight -> do
ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
&& (isNothing $ wonlost ud)) $ do
let rawRot = (sRot $ ship ud) - 15 * sec
newRot
| rawRot > 360 = rawRot - 360
| rawRot < 0 = rawRot + 360
| otherwise = rawRot
putAffection ud
{ ship = (ship ud)
{ sRot = newRot
}
}
SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
&& (isNothing $ wonlost wd)) $ do
ud <- getAffection
let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
putAffection ud
{ ship = (ship ud)
{ sVel = (vx, vy)
}
}
-- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
SDL.KeycodeSpace ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
&& (isNothing $ wonlost wd)) $ do
ud <- getAffection
liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
Operation "gegl:pixelize"
[ Property "size-x" $ PropertyInt 8
, Property "size-y" $ PropertyInt 8
]
-- ad <- get
let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
tempRoot <- liftIO gegl_node_new
tempRect <- liftIO $ gegl_node_new_child tempRoot $
Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble posX
, Property "y" $ PropertyDouble posY
, Property "width" $ PropertyDouble 4
, Property "height" $ PropertyDouble 4
, Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
]
tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
ips <- insertParticle (shots ud)
Particle
{ particleTimeToLive = 5
, particleCreation = elapsedTime ad
, particlePosition = (posX, posY)
, particleRotation = 0
, particleVelocity =
( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud))
)
, particlePitchRate = 0
, particleRootNode = tempRoot
, particleNodeGraph = M.fromList
[ ("root", tempRoot)
, ("over", tempOver)
, ("rect", tempRect)
]
, particleStackCont = tempOver
, particleDrawFlange = tempOver
}
putAffection $ ud
{ shots = ips
, pixelSize = 8
}
SDL.KeycodeR ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
&& isJust (wonlost wd)) $ do
liftIO $ traceIO "reloading"
liftIO $ clean wd
nd <- liftIO $ load
putAffection nd
loadGame
_ -> return ()
SDL.WindowClosedEvent _ -> do
traceM "seeya!"
quit
_ -> return ()