nek0/haskelloids
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

linted

Browse source
This commit is contained in:
nek0 2017-12-21 14:43:13 +01:00
parent 55b5280636
commit e653391ab6
6 changed files with 42 additions and 46 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
src/Commons.hs
View file

@ -1,5 +1,3 @@
{-# LANGUAGE RecordWildCards #-}
module Commons where
import Affection
@ -26,7 +24,7 @@ toR :: Double -> Double
toR deg = deg * pi / 180
wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
wrapAround (V2 nx ny) width = (V2 nnx nny)
wrapAround (V2 nx ny) width = V2 nnx nny
where
nnx
| nx > 800 + half = nx - (800 + width)
@ -119,4 +117,4 @@ drawHaskelloid (Haskelloid pos _ rot _ div img) = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
where
dim = (fmap (/ fromIntegral div) (V2 100 100))
dim = fmap (/ fromIntegral div) (V2 100 100)

62
src/InGame.hs
View file

@ -77,8 +77,8 @@ 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)
ppos = sPos + (V2 0 25 `rotVec` sRot)
pVel = sVel + (V2 0 pewVel `rotVec` sRot)
putAffection ud
{ shots = npew : shots ud
}
@ -88,7 +88,7 @@ accelShip vel = do
ud <- getAffection
dt <- getDelta
let s = ship ud
nVel = sVel s + fmap (realToFrac dt *) ((V2 0 vel) `rotVec` sRot s)
nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
putAffection ud
{ ship = s
{ sVel = nVel
@ -101,15 +101,15 @@ rotateShip deg = do
dt <- getDelta
putAffection ud
{ ship = (ship ud)
{ sRot = (sRot $ ship ud) - deg * realToFrac dt
{ sRot = sRot (ship ud) - deg * realToFrac dt
}
}
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
where
nx = x * (cos $ dtor deg) + y * (sin $ dtor deg)
ny = x * (sin $ dtor deg) - y * (cos $ dtor deg)
nx = x * cos (dtor deg) + y * sin (dtor deg)
ny = x * sin (dtor deg) - y * cos (dtor deg)
dtor = (pi / 180 *)
updateGame :: Double -> Affection UserData ()
@ -162,7 +162,7 @@ checkShotDown =
let ndiv = hDiv + 1
if ndiv > 5
then return []
else return $
else return
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
]
@ -211,36 +211,34 @@ drawGame = do
mapM_ drawHaskelloid (haskelloids ud)
mapM_ drawPew (shots ud)
case wonlost ud of
Just Lost -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU LOST!"
fillColor ctx (rgba 255 128 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Just Won -> liftIO $ do
let ctx = nano ud
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "YOU WON!"
fillColor ctx (rgba 128 255 0 255)
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
Just x -> drawWonLost x
Nothing -> drawShip (ship ud)
drawWonLost :: WonLost -> Affection UserData ()
drawWonLost wl = do
ctx <- nano <$> getAffection
liftIO $ do
let color = case wl of
Won -> rgba 128 255 0 255
Lost -> rgba 255 128 0 255
text = case wl of
Won -> "YOU WON!"
Lost -> "YOU LOsT!"
save ctx
fontSize ctx 120
fontFace ctx "modulo"
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 text
fillColor ctx color
fontSize ctx 40
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do
ctx <- nano <$> getAffection
liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
liftIO $ drawImage ctx sImg (sPos - fmap (/2) dim) dim sRot 255
where
dim = V2 40 40

4
src/Init.hs
View file

@ -56,8 +56,8 @@ load = do
exitFailure
liftIO $ logIO A.Debug "Initializing subsystems"
subs <- Subsystems
<$> (return . Window =<< newTVarIO [])
<*> (return . Keyboard =<< newTVarIO [])
<$> (Window <$> newTVarIO [])
<*> (Keyboard <$> newTVarIO [])
liftIO $ logIO A.Debug "Setting viewport"
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
liftIO $ logIO A.Debug "Returning UserData"

2
src/Main.hs
View file

@ -41,7 +41,7 @@ main = do
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = (\_ -> return ())
, cleanUp = \_ -> return ()
}
pre :: Affection UserData ()

10
src/Menu.hs
View file

@ -24,7 +24,7 @@ import Foreign.C.Types
import Types
import Commons
loadMenu :: (Affection UserData ()) -> Affection UserData ()
loadMenu :: Affection UserData () -> Affection UserData ()
loadMenu stateChange = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection
@ -54,12 +54,12 @@ updateMenu sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of
FadeIn ttl -> do
FadeIn ttl ->
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
FadeOut ttl -> do
FadeOut ttl ->
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
@ -72,8 +72,8 @@ drawMenu = do
liftIO $ do
let ctx = nano ud
alpha fio = case fio of
FadeIn d -> (floor (255 * (1 - d)))
FadeOut d -> (floor (255 * d))
FadeIn d -> floor (255 * (1 - d))
FadeOut d -> floor (255 * d)
save ctx
fontSize ctx 120
fontFace ctx "modulo"

4
src/Types.hs
View file

@ -85,7 +85,7 @@ instance Participant Window WindowMessage UserData where
return $ MsgId uuid MsgWindowEmptyEvent
partUnSubscribe (Window t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
@ -106,7 +106,7 @@ instance Participant Keyboard KeyboardMessage UserData where
return $ MsgId uuid MsgKeyboardEmptyEvent
partUnSubscribe (Keyboard t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p