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

linted

Browse source
This commit is contained in:
nek0 2017-01-03 19:36:01 +01:00
parent a1c6ce6b92
commit b2e622a5c8
3 changed files with 53 additions and 57 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
src/Commons.hs
View file

@ -11,7 +11,7 @@ import qualified Data.Map as M
import Data.List (delete) import Data.List (delete)
import Data.Maybe (catMaybes) import Data.Maybe (catMaybes)
import Control.Monad (foldM, when) import Control.Monad (foldM, unless)
import System.Random (randomRIO) import System.Random (randomRIO)
@ -24,7 +24,7 @@ toR deg = deg * pi / 180
clean :: UserData -> IO () clean :: UserData -> IO ()
clean ud = do clean ud = do
mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
gegl_node_drop $ nodeGraph ud M.! KeyRoot gegl_node_drop $ nodeGraph ud M.! KeyRoot
load :: SDL.Surface -> IO UserData load :: SDL.Surface -> IO UserData
@ -47,11 +47,11 @@ load _ = do
pnop <- gegl_node_new_child root $ Operation "gegl:nop" [] pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
hnop <- gegl_node_new_child root $ Operation "gegl:nop" [] hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
fgnop <- gegl_node_new_child root $ Operation "gegl:nop" [] fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
sover <- gegl_node_new_child root $ defaultOverOperation sover <- gegl_node_new_child root defaultOverOperation
hover <- gegl_node_new_child root $ defaultOverOperation hover <- gegl_node_new_child root defaultOverOperation
pover <- gegl_node_new_child root $ defaultOverOperation pover <- gegl_node_new_child root defaultOverOperation
bgover <- gegl_node_new_child root $ defaultOverOperation bgover <- gegl_node_new_child root defaultOverOperation
fgover <- gegl_node_new_child root $ defaultOverOperation fgover <- gegl_node_new_child root defaultOverOperation
translate <- gegl_node_new_child root $ Operation "gegl:translate" translate <- gegl_node_new_child root $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble 375 [ Property "x" $ PropertyDouble 375
, Property "y" $ PropertyDouble 275 , Property "y" $ PropertyDouble 275
@ -120,7 +120,7 @@ load _ = do
, Property "y" $ PropertyDouble 300 , Property "y" $ PropertyDouble 300
, Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
] ]
menuOver <- gegl_node_new_child root $ defaultOverOperation menuOver <- gegl_node_new_child root defaultOverOperation
gegl_node_link menuHeading menuTranslateHeading gegl_node_link menuHeading menuTranslateHeading
gegl_node_link_many [menuText, menuTranslateText, menuOver] gegl_node_link_many [menuText, menuTranslateText, menuOver]
_ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux" _ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux"
@ -160,7 +160,7 @@ load _ = do
-- ) [] ([0..9] :: [Int]) -- ) [] ([0..9] :: [Int])
-- liftIO $ gegl_node_link_many $ map hFlange hs -- liftIO $ gegl_node_link_many $ map hFlange hs
-- liftIO $ gegl_node_link (last $ map hFlange hs) hnop -- liftIO $ gegl_node_link (last $ map hFlange hs) hnop
return $ UserData return UserData
{ nodeGraph = myMap { nodeGraph = myMap
, ship = Ship , ship = Ship
{ sPos = (375, 275) { sPos = (375, 275)
@ -188,8 +188,8 @@ insertHaskelloid hasks split (px, py) = do
Just x -> return $ x + 1 Just x -> return $ x + 1
rot <- liftIO $ randomRIO (0, 360) rot <- liftIO $ randomRIO (0, 360)
pitch <- liftIO $ randomRIO (-45, 45) pitch <- liftIO $ randomRIO (-45, 45)
tempRoot <- liftIO $ gegl_node_new tempRoot <- liftIO gegl_node_new
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
[ Property "path" $ PropertyString "assets/haskelloid.svg" [ Property "path" $ PropertyString "assets/haskelloid.svg"
, Property "width" $ PropertyInt (100 `div` rdiv) , Property "width" $ PropertyInt (100 `div` rdiv)
@ -262,14 +262,14 @@ haskelloidShotDown h = do
updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
updateHaskelloid sec h@Haskelloid{..} = do updateHaskelloid sec h@Haskelloid{..} = do
let newX = (fst $ hPos) + sec * (fst $ hVel) let newX = fst hPos + sec * fst hVel
newY = (snd $ hPos) + sec * (snd $ hVel) newY = snd hPos + sec * snd hVel
newRot = hRot + hPitch * sec newRot = hRot + hPitch * sec
(nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv) (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
-- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny -- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate" liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx [ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble $ nny , Property "y" $ PropertyDouble nny
] ]
liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate" liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble newRot [ Property "degrees" $ PropertyDouble newRot
@ -286,9 +286,7 @@ updateHaskelloid sec h@Haskelloid{..} = do
50 50
) )
_ -> return Nothing _ -> return Nothing
maybe (return ()) (\_ -> maybe (return ()) (const lose) lost
lose
) lost
return h return h
{ hPos = (nnx, nny) { hPos = (nnx, nny)
, hRot = newRot , hRot = newRot
@ -297,23 +295,23 @@ updateHaskelloid sec h@Haskelloid{..} = do
wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
wrapAround (nx, ny) width = (nnx, nny) wrapAround (nx, ny) width = (nnx, nny)
where where
nnx = nnx
if nx > 800 | nx > 800 = nx - (800 + width)
then nx - (800 + width) | nx < -width = nx + 800 + width
else if nx < -width then nx + 800 + width else nx | otherwise = nx
nny = nny
if ny > 600 | ny > 600 = ny - (600 + width)
then ny - (600 + width) | ny < -width = ny + 600 + width
else if ny < -width then ny + 600 + width else ny | otherwise = ny
shotsUpd :: Double -> Particle -> Affection UserData Particle shotsUpd :: Double -> Particle -> Affection UserData Particle
shotsUpd sec part@Particle{..} = do shotsUpd sec part@Particle{..} = do
let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity) let newX = fst particlePosition + sec * fromIntegral (fst particleVelocity)
newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity) newY = snd particlePosition + sec * fromIntegral (snd particleVelocity)
(nnx, nny) = wrapAround (newX, newY) 4 (nnx, nny) = wrapAround (newX, newY) 4
liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle" liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble $ nnx [ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble $ nny , Property "y" $ PropertyDouble nny
] ]
ud <- getAffection ud <- getAffection
inters <- catMaybes <$> mapM (\h -> do inters <- catMaybes <$> mapM (\h -> do
@ -329,7 +327,7 @@ shotsUpd sec part@Particle{..} = do
Just _ -> return $ Just h Just _ -> return $ Just h
Nothing -> return Nothing Nothing -> return Nothing
) (haskelloids ud) ) (haskelloids ud)
when (not $ null inters) $ unless (null inters) $
haskelloidShotDown $ head inters haskelloidShotDown $ head inters
lost <- liftIO $ gegl_rectangle_intersect lost <- liftIO $ gegl_rectangle_intersect
(GeglRectangle (floor nnx) (floor nny) 4 4) (GeglRectangle (floor nnx) (floor nny) 4 4)
@ -339,12 +337,10 @@ shotsUpd sec part@Particle{..} = do
50 50
50 50
) )
maybe (return ()) (\_ -> maybe (return ()) (const lose) lost
lose
) lost
return part return part
{ particlePosition = (nnx, nny) { particlePosition = (nnx, nny)
, particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive , particleTimeToLive = if not $ null inters then 0 else particleTimeToLive
} }
shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()

40
src/InGame.hs
View file

@ -41,7 +41,7 @@ loadGame = do
{ sPos = (375, 275) { sPos = (375, 275)
, sVel = (0, 0) , sVel = (0, 0)
, sRot = 0 , sRot = 0
, sFlange = (nodeGraph ud M.! KeyShipRotate) , sFlange = nodeGraph ud M.! KeyShipRotate
} }
, pixelSize = 3 , pixelSize = 3
, state = InGame , state = InGame
@ -73,12 +73,12 @@ updateGame sec = do
putAffection ud putAffection ud
{ pixelSize = pixelSize ud -1 { pixelSize = pixelSize ud -1
} }
let nx = (fst $ sPos $ ship ud) + (fst $ sVel $ ship ud) * sec let nx = fst (sPos $ ship ud) + fst (sVel $ ship ud) * sec
ny = (snd $ sPos $ ship ud) + (snd $ sVel $ ship ud) * sec ny = snd (sPos $ ship ud) + snd (sVel $ ship ud) * sec
(nnx, nny) = wrapAround (nx, ny) 50 (nnx, nny) = wrapAround (nx, ny) 50
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate" liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate"
[ Property "x" $ PropertyDouble $ nnx [ Property "x" $ PropertyDouble nnx
, Property "y" $ PropertyDouble $ nny , Property "y" $ PropertyDouble nny
] ]
liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate" liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate"
[ Property "degrees" $ PropertyDouble $ sRot $ ship ud [ Property "degrees" $ PropertyDouble $ sRot $ ship ud
@ -108,13 +108,13 @@ handleGameEvent sec e = do
wd <- getAffection wd <- getAffection
case SDL.eventPayload e of case SDL.eventPayload e of
SDL.KeyboardEvent dat -> SDL.KeyboardEvent dat ->
case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
SDL.KeycodeLeft -> do SDL.KeycodeLeft -> do
ud <- getAffection ud <- getAffection
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
putAffection ud putAffection ud
{ ship = (ship ud) { ship = (ship ud)
{ sRot = (sRot $ ship ud) + 270 * sec { sRot = sRot (ship ud) + 270 * sec
} }
} }
SDL.KeycodeRight -> do SDL.KeycodeRight -> do
@ -122,14 +122,14 @@ handleGameEvent sec e = do
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
putAffection ud putAffection ud
{ ship = (ship ud) { ship = (ship ud)
{ sRot = (sRot $ ship ud) - 270 * sec { sRot = sRot (ship ud) - 270 * sec
} }
} }
SDL.KeycodeUp -> SDL.KeycodeUp ->
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
ud <- getAffection ud <- getAffection
let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud) let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud) vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
putAffection ud putAffection ud
{ ship = (ship ud) { ship = (ship ud)
{ sVel = (vx, vy) { sVel = (vx, vy)
@ -144,19 +144,19 @@ handleGameEvent sec e = do
, Property "size-y" $ PropertyInt 8 , Property "size-y" $ PropertyInt 8
] ]
-- ad <- get -- ad <- get
let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud) 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) posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
tempRoot <- liftIO $ gegl_node_new tempRoot <- liftIO gegl_node_new
tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle" tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
[ Property "x" $ PropertyDouble $ posX [ Property "x" $ PropertyDouble posX
, Property "y" $ PropertyDouble $ posY , Property "y" $ PropertyDouble posY
, Property "width" $ PropertyDouble 4 , Property "width" $ PropertyDouble 4
, Property "height" $ PropertyDouble 4 , Property "height" $ PropertyDouble 4
, Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1) , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
] ]
tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
_ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux" _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
ips <- insertParticle (shots ud) $ ips <- insertParticle (shots ud)
Particle Particle
{ particleTimeToLive = 5 { particleTimeToLive = 5
, particleCreation = elapsedTime ad , particleCreation = elapsedTime ad
@ -165,8 +165,8 @@ handleGameEvent sec e = do
, particleVelocity = , particleVelocity =
-- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud))) -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
-- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud))) -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud)))
( (floor $ -200 * (sin $ toR $ sRot $ ship ud)) ( (floor $ (-200) * (sin $ toR $ sRot $ ship ud))
, (floor $ -200 * (cos $ toR $ sRot $ ship ud)) , (floor $ (-200) * (cos $ toR $ sRot $ ship ud))
) )
, particlePitchRate = Rad 0 , particlePitchRate = Rad 0
, particleRootNode = tempRoot , particleRootNode = tempRoot

4
src/Main.hs
View file

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings, RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}
module Main where module Main where
import Affection import Affection
@ -23,7 +23,7 @@ import Menu
import InGame import InGame
main :: IO () main :: IO ()
main = withAffection $ AffectionConfig main = withAffection AffectionConfig
{ initComponents = All { initComponents = All
, windowTitle = "Haskelloids" , windowTitle = "Haskelloids"
, windowConfig = defaultWindow , windowConfig = defaultWindow