hunting warnings
This commit is contained in:
parent
248043ba24
commit
8104c636cd
7 changed files with 22 additions and 42 deletions
|
@ -1,13 +1,7 @@
|
||||||
module Commons where
|
module Commons where
|
||||||
|
|
||||||
import Affection
|
import Affection
|
||||||
import qualified SDL
|
|
||||||
|
|
||||||
import qualified Data.Map as M
|
|
||||||
import Data.List (delete)
|
|
||||||
import Data.Maybe (catMaybes, isJust)
|
|
||||||
|
|
||||||
import Control.Monad (foldM, unless, when)
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
import System.Random (randomRIO)
|
import System.Random (randomRIO)
|
||||||
|
@ -24,25 +18,25 @@ toR :: Double -> Double
|
||||||
toR deg = deg * pi / 180
|
toR deg = deg * pi / 180
|
||||||
|
|
||||||
wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
|
wrapAround :: (Fractional t, Ord t, Num t) => V2 t -> t -> V2 t
|
||||||
wrapAround (V2 nx ny) width = V2 nnx nny
|
wrapAround (V2 nx ny) w = V2 nnx nny
|
||||||
where
|
where
|
||||||
nnx
|
nnx
|
||||||
| nx > 800 + half = nx - (800 + width)
|
| nx > 800 + half = nx - (800 + w)
|
||||||
| nx < -half = nx + 800 + width
|
| nx < -half = nx + 800 + w
|
||||||
| otherwise = nx
|
| otherwise = nx
|
||||||
nny
|
nny
|
||||||
| ny > 600 + half = ny - (600 + width)
|
| ny > 600 + half = ny - (600 + w)
|
||||||
| ny < -half = ny + 600 + width
|
| ny < -half = ny + 600 + w
|
||||||
| otherwise = ny
|
| otherwise = ny
|
||||||
half = width / 2
|
half = w / 2
|
||||||
|
|
||||||
newHaskelloids :: Affection UserData [Haskelloid]
|
newHaskelloids :: Affection UserData [Haskelloid]
|
||||||
newHaskelloids =
|
newHaskelloids =
|
||||||
do
|
do
|
||||||
img <- haskImage <$> getAffection
|
img <- haskImage <$> getAffection
|
||||||
liftIO $ mapM (\_ -> do
|
liftIO $ mapM (\_ -> do
|
||||||
div <- randomRIO (1, 2)
|
d <- randomRIO (1, 2)
|
||||||
(posx, posy) <- getCoordinates div
|
(posx, posy) <- getCoordinates d
|
||||||
velx <- randomRIO (-10, 10)
|
velx <- randomRIO (-10, 10)
|
||||||
vely <- randomRIO (-10, 10)
|
vely <- randomRIO (-10, 10)
|
||||||
rot <- randomRIO (-180, 180)
|
rot <- randomRIO (-180, 180)
|
||||||
|
@ -52,15 +46,15 @@ newHaskelloids =
|
||||||
(V2 velx vely)
|
(V2 velx vely)
|
||||||
rot
|
rot
|
||||||
pitch
|
pitch
|
||||||
div
|
d
|
||||||
img
|
img
|
||||||
) [1..10]
|
) ([1..10] :: [Int])
|
||||||
where
|
where
|
||||||
getCoordinates div = do
|
getCoordinates d = do
|
||||||
posx <- randomRIO (0, 800)
|
posx <- randomRIO (0, 800)
|
||||||
posy <- randomRIO (0, 600)
|
posy <- randomRIO (0, 600)
|
||||||
if distance (V2 posx posy) (V2 400 300) < 20 + (50 / fromIntegral div)
|
if distance (V2 posx posy) (V2 400 300) < 20 + (50 / fromIntegral d)
|
||||||
then getCoordinates div
|
then getCoordinates d
|
||||||
else return (posx, posy)
|
else return (posx, posy)
|
||||||
|
|
||||||
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
|
updateHaskelloid :: Double -> Haskelloid -> Haskelloid
|
||||||
|
@ -120,8 +114,8 @@ drawSpinner ctx x y cr ct = do
|
||||||
restore ctx
|
restore ctx
|
||||||
|
|
||||||
drawHaskelloid :: Haskelloid -> Affection UserData ()
|
drawHaskelloid :: Haskelloid -> Affection UserData ()
|
||||||
drawHaskelloid (Haskelloid pos _ rot _ div img) = do
|
drawHaskelloid (Haskelloid pos _ rot _ d img) = do
|
||||||
ctx <- nano <$> getAffection
|
ctx <- nano <$> getAffection
|
||||||
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
|
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 255
|
||||||
where
|
where
|
||||||
dim = fmap (/ fromIntegral div) (V2 100 100)
|
dim = fmap (/ fromIntegral d) (V2 100 100)
|
||||||
|
|
|
@ -221,7 +221,7 @@ drawWonLost wl = do
|
||||||
let color = case wl of
|
let color = case wl of
|
||||||
Won -> rgba 128 255 0 255
|
Won -> rgba 128 255 0 255
|
||||||
Lost -> rgba 255 128 0 255
|
Lost -> rgba 255 128 0 255
|
||||||
text = case wl of
|
textStr = case wl of
|
||||||
Won -> "YOU WON!"
|
Won -> "YOU WON!"
|
||||||
Lost -> "YOU LOsT!"
|
Lost -> "YOU LOsT!"
|
||||||
save ctx
|
save ctx
|
||||||
|
@ -229,7 +229,7 @@ drawWonLost wl = do
|
||||||
fontFace ctx "modulo"
|
fontFace ctx "modulo"
|
||||||
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
textAlign ctx (S.fromList [AlignCenter,AlignTop])
|
||||||
fillColor ctx (rgba 255 255 255 255)
|
fillColor ctx (rgba 255 255 255 255)
|
||||||
textBox ctx 0 200 800 text
|
textBox ctx 0 200 800 textStr
|
||||||
fillColor ctx color
|
fillColor ctx color
|
||||||
fontSize ctx 40
|
fontSize ctx 40
|
||||||
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
|
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
|
||||||
|
|
|
@ -4,7 +4,6 @@ module Init where
|
||||||
import Affection as A
|
import Affection as A
|
||||||
|
|
||||||
import SDL (($=))
|
import SDL (($=))
|
||||||
import qualified SDL
|
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
|
@ -15,7 +14,6 @@ import Control.Monad (when)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Concurrent.STM
|
import Control.Concurrent.STM
|
||||||
|
|
||||||
import System.Random
|
|
||||||
import System.Exit (exitFailure)
|
import System.Exit (exitFailure)
|
||||||
|
|
||||||
import Linear
|
import Linear
|
||||||
|
@ -77,4 +75,5 @@ load = do
|
||||||
, font = fromJust mfont
|
, font = fromJust mfont
|
||||||
, subsystems = subs
|
, subsystems = subs
|
||||||
, haskImage = fromJust mhaskImage
|
, haskImage = fromJust mhaskImage
|
||||||
|
, stateUUIDs = UUIDClean [] []
|
||||||
}
|
}
|
||||||
|
|
|
@ -6,8 +6,6 @@ import SDL (($=))
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
import qualified Graphics.Rendering.OpenGL as GL
|
import qualified Graphics.Rendering.OpenGL as GL
|
||||||
|
|
||||||
import qualified Data.Map as M
|
|
||||||
|
|
||||||
import Linear as L
|
import Linear as L
|
||||||
|
|
||||||
import NanoVG hiding (V2(..), V4(..))
|
import NanoVG hiding (V2(..), V4(..))
|
||||||
|
@ -18,7 +16,6 @@ import Control.Monad.IO.Class (liftIO)
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Commons
|
|
||||||
import StateMachine ()
|
import StateMachine ()
|
||||||
import Init
|
import Init
|
||||||
|
|
||||||
|
@ -51,8 +48,8 @@ pre = do
|
||||||
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of
|
_ <- partSubscribe (subWindow subs) $ \msg -> case msg of
|
||||||
MsgWindowResize _ _ (V2 w h) -> do
|
MsgWindowResize _ _ (V2 w h) -> do
|
||||||
liftIO $ logIO A.Debug "Window has been resized"
|
liftIO $ logIO A.Debug "Window has been resized"
|
||||||
let nw = floor $ fromIntegral h * (800/600)
|
let nw = floor $ (fromIntegral h * (800/600) :: Double)
|
||||||
dw = floor $ (fromIntegral w - fromIntegral nw) / 2
|
dw = floor $ ((fromIntegral w - fromIntegral nw) / 2 :: Double)
|
||||||
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
|
GL.viewport $= (GL.Position dw 0, GL.Size nw h)
|
||||||
_ -> return ()
|
_ -> return ()
|
||||||
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
|
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
|
||||||
|
|
11
src/Menu.hs
11
src/Menu.hs
|
@ -3,21 +3,12 @@ module Menu where
|
||||||
import Affection as A
|
import Affection as A
|
||||||
import qualified SDL
|
import qualified SDL
|
||||||
|
|
||||||
import Debug.Trace
|
|
||||||
|
|
||||||
import Data.Maybe
|
|
||||||
import qualified Data.Set as S
|
import qualified Data.Set as S
|
||||||
|
|
||||||
import Control.Monad (when)
|
import Control.Monad (when)
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import NanoVG
|
||||||
|
|
||||||
import NanoVG hiding (V2(..), V4(..))
|
|
||||||
|
|
||||||
import Linear
|
|
||||||
|
|
||||||
import Foreign.C.Types
|
|
||||||
|
|
||||||
-- internal imports
|
-- internal imports
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
|
||||||
module StateMachine where
|
module StateMachine where
|
||||||
|
|
|
@ -3,7 +3,6 @@
|
||||||
module Types where
|
module Types where
|
||||||
|
|
||||||
import Affection
|
import Affection
|
||||||
import qualified SDL
|
|
||||||
import NanoVG hiding (V2(..))
|
import NanoVG hiding (V2(..))
|
||||||
import Linear
|
import Linear
|
||||||
|
|
||||||
|
@ -16,7 +15,6 @@ data UserData = UserData
|
||||||
, shots :: [Pew]
|
, shots :: [Pew]
|
||||||
-- , debris :: ParticleSystem
|
-- , debris :: ParticleSystem
|
||||||
, wonlost :: Maybe WonLost
|
, wonlost :: Maybe WonLost
|
||||||
, pixelSize :: Int
|
|
||||||
, state :: State
|
, state :: State
|
||||||
, fade :: MenuFade
|
, fade :: MenuFade
|
||||||
, nano :: Context
|
, nano :: Context
|
||||||
|
|
Loading…
Reference in a new issue