playable!

This commit is contained in:
nek0 2017-12-21 05:21:20 +01:00
parent a12707d740
commit a9fc5f24f6
5 changed files with 107 additions and 17 deletions

Binary file not shown.

Before

Width:  |  Height:  |  Size: 6.3 KiB

After

Width:  |  Height:  |  Size: 6.6 KiB

View file

@ -5,30 +5,40 @@ import Affection as A
import qualified SDL
import qualified Data.Set as S
import Data.Maybe (isNothing)
import Data.Maybe (isNothing, catMaybes)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import Linear
import NanoVG hiding (V2(..))
import Foreign.C.Types (CFloat(..))
import Types
import Commons
dVel :: Float
dVel = 100
pewVel :: Float
pewVel = 200
pewTTL :: Double
pewTTL = 10
dRot :: Float
dRot = 150
loadGame :: Affection UserData () -> Affection UserData ()
loadGame stateChange = do
loadGame :: Affection UserData () -> Affection UserData () -> Affection UserData ()
loadGame stateChange clean = do
liftIO $ logIO A.Debug "loading game"
ud <- getAffection
nhs <- newHaskelloids
kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange)
kid <- partSubscribe (subKeyboard $ subsystems ud) (handleGameKeys stateChange clean)
putAffection ud
{ stateUUIDs = UUIDClean [] [kid]
, haskelloids = nhs
@ -42,18 +52,17 @@ loadGame stateChange = do
, wonlost = Nothing
}
handleGameKeys :: Affection UserData () -> KeyboardMessage -> Affection UserData ()
handleGameKeys stateChange kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
handleGameKeys :: Affection UserData () -> Affection UserData () -> KeyboardMessage -> Affection UserData ()
handleGameKeys stateChange clean kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
liftIO $ logIO A.Debug "TODO: PEW!"
liftIO $ logIO A.Debug "PEW!"
shoot
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
liftIO $ logIO A.Debug "Reloading"
putAffection ud
{ stateUUIDs = UUIDClean [] []
}
loadGame stateChange
unless (isNothing $ wonlost ud) $ do
liftIO $ logIO A.Debug "Reloading"
clean
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
@ -63,6 +72,17 @@ handleGameKeys stateChange kbdev = when (msgKbdKeyMotion kbdev == SDL.Pressed) $
SDL.KeycodeD -> rotateShip (-dRot)
_ -> return ()
shoot :: Affection UserData ()
shoot = do
ud <- getAffection
let Ship{..} = ship ud
npew = Pew ppos pVel pewTTL
ppos = sPos + ((V2 0 25) `rotVec` sRot)
pVel = sVel + ((V2 0 pewVel) `rotVec` sRot)
putAffection ud
{ shots = npew : shots ud
}
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
@ -96,10 +116,13 @@ updateGame :: Double -> Affection UserData ()
updateGame sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
putAffection ud
{ haskelloids = nhs
, shots = npews
, ship = updateShip sec (ship ud)
}
checkShotDown
ud2 <- getAffection
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
@ -111,6 +134,51 @@ updateGame sec = do
{ wonlost = Just Lost
}
)
when (isNothing (wonlost ud2) && null (haskelloids ud2))
(putAffection ud2
{ wonlost = Just Won
}
)
checkShotDown :: Affection UserData ()
checkShotDown =
do
ud <- getAffection
let shoots = shots ud
hasks = haskelloids ud
pairs = catMaybes $ concatMap (crossOut hasks) shoots
deadHasks = map fst pairs
nhask = foldl (\acc a -> filter (\x -> a /= x) acc) hasks deadHasks
npews = foldl (\acc a -> filter (\x -> a /= x) acc) shoots (map snd pairs)
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
n1velx <- randomRIO (-10, 10)
n1vely <- randomRIO (-10, 10)
n1rot <- randomRIO (-180, 180)
n1pitch <- randomRIO (-pi, pi)
n2velx <- randomRIO (-10, 10)
n2vely <- randomRIO (-10, 10)
n2rot <- randomRIO (-180, 180)
n2pitch <- randomRIO (-pi, pi)
let ndiv = hDiv + 1
if ndiv > 5
then return []
else return $
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
]
) deadHasks
putAffection ud
{ shots = npews
, haskelloids = nhask ++ children
}
where
crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
crossOut hs p =
foldl (\acc h ->
if distance (pPos p) (hPos h) < (50 / fromIntegral (hDiv h))
then Just (h, p) : acc
else Nothing : acc
) [] hs
checkCollision :: Ship -> Haskelloid -> Bool
checkCollision s h =
@ -129,10 +197,19 @@ updateShip ddt s@Ship{..} = s
where
dt = realToFrac ddt
updatePew :: Double -> Pew -> Pew
updatePew ddt p@Pew{..} = p
{ pPos = wrapAround (pPos + fmap (dt *) pVel) 0
, pTTL = pTTL - ddt
}
where
dt = realToFrac ddt
drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
mapM_ drawPew (shots ud)
case wonlost ud of
Just Lost -> liftIO $ do
let ctx = nano ud
@ -154,9 +231,9 @@ drawGame = do
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU WON!"
fillColor ctx (rgba 255 128 0 255)
fillColor ctx (rgba 128 255 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit"
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Nothing -> drawShip (ship ud)
@ -166,3 +243,15 @@ drawShip Ship{..} = do
liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
where
dim = V2 40 40
drawPew :: Pew -> Affection UserData ()
drawPew Pew{..} = do
ctx <- nano <$> getAffection
liftIO $ do
let (V2 x y) = fmap CFloat pPos
save ctx
beginPath ctx
fillColor ctx (rgba 255 128 0 255)
circle ctx x y 2
fill ctx
restore ctx

View file

@ -31,7 +31,7 @@ main = do
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
-- , SDL.glColorPrecision = V4 0 8 8 8
, SDL.glColorPrecision = V4 8 8 8 1
}
}
, initScreenMode = SDL.Windowed
@ -61,6 +61,7 @@ pre = do
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
SDL.KeycodeO -> toggleScreen
_ -> return ()
return ()

View file

@ -11,7 +11,7 @@ import Menu
instance StateMachine State UserData where
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
smLoad InGame = loadGame (smClean InGame >> smLoad Menu)
smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame)
smUpdate Menu = updateMenu

View file

@ -37,7 +37,7 @@ data Pew = Pew
{ pPos :: V2 Float
, pVel :: V2 Float
, pTTL :: Double
}
} deriving (Eq)
data Haskelloid = Haskelloid
{ hPos :: V2 Float