hunting warnings in Test

This commit is contained in:
nek0 2018-05-30 17:32:00 +02:00
parent 5c70976678
commit f6db4f5e5c

View file

@ -1,13 +1,11 @@
module Test where
import Affection as A hiding (get)
import Affection as A
import SDL (get, ($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL hiding (get)
import NanoVG hiding (V2(..))
import Control.Monad (when, unless, void)
import Control.Monad (when, void)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import Control.Concurrent (forkOS)
@ -26,8 +24,6 @@ import Linear hiding (E)
import Foreign.C.Types (CFloat(..))
import Debug.Trace
-- internal imports
import Interior
@ -59,7 +55,7 @@ loadMap = do
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex)
liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
createEntity $ newEntity
void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5)
, vel = Just (V2 0 0)
, player = Just ()
@ -68,9 +64,9 @@ loadMap = do
}
void $ mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO $ newEmptyMVar
future <- liftIO newEmptyMVar
_ <- liftIO $ forkOS $ getPath (fmap floor npcpos) future nnex inter
createEntity $ newEntity
void $ createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0)
, velFact = Just fact
@ -100,7 +96,7 @@ mouseToPlayer mv2 = do
(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2
let dr = (ry / sin (atan (1/2)) / 2) + rx
dc = rx - (ry / sin (atan (1/2)) / 2)
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $
emap allEnts $ do
with player
pure $ unchanged
@ -116,7 +112,7 @@ movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) =
mouseToPlayer m
movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do
ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $
emap allEnts $ do
with player
pure $ unchanged
@ -131,21 +127,19 @@ drawMap :: Affection UserData ()
drawMap = do
ud <- getAffection
dt <- getDelta
(_, (playerPos, playerRot, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
(pc, dir) <- fmap head $ efor allEnts $ do
(_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do
pc <- fmap head $ efor allEnts $ do
with player
with pos
with rot
pos' <- query pos
rot' <- query rot
pure (pos', rot')
pure pos'
posanims <- efor allEnts $ do
with anim
with pos
state <- query anim
stat <- query anim
pos' <- query pos
return (pos', state)
return (pc, dir, posanims)
return (pos', stat)
return (pc, posanims)
let V2 pr pc = playerPos
mat = imgMat (stateData ud)
ctx = nano ud
@ -171,16 +165,14 @@ drawMap = do
fillColor ctx (rgb 255 255 255)
fill ctx
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> do
drawTile ud ctx posanims pr pc i j t
)
(uncurry (drawTile ud ctx posanims pr pc i))
(reverse $ zip [1..] ls))
(zip [1..] (toLists mat))
fontSize ctx 20
fontFace ctx (assetFonts ud Map.! FontBedstead)
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgb 255 128 0)
textBox ctx 0 0 200 ("FPS: " `T.append` (T.pack $ Prelude.take 5 $ show (1/dt)))
textBox ctx 0 0 200 ("FPS: " `T.append` T.pack (Prelude.take 5 $ show (1/dt)))
drawTile
:: UserData
@ -194,15 +186,16 @@ drawTile
-> IO ()
drawTile ud ctx posanims pr pc row col img =
when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) &&
(realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $
((realToFrac x :: Double) < 1280 &&
(realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $
do
let lt = Prelude.filter (\(V2 nr nc, _) ->
(any (\m -> nr < (fromIntegral (floor nr :: Int)) + m) maxrs &&
any (\m -> nc > (fromIntegral (floor nc :: Int)) + m) maxcs)
(any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
any (\m -> nc > fromIntegral (floor nc :: Int) + m) maxcs)
) sorted
ge = Prelude.filter (\(V2 nr nc, _) -> not
(any (\m -> nr < (fromIntegral (floor nr :: Int)) + m) maxrs &&
any (\m -> nc > (fromIntegral (floor nc :: Int)) + m) maxcs)
(any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
any (\m -> nc > fromIntegral (floor nc :: Int) + m) maxcs)
) sorted
save ctx
mapM_ drawAnim lt
@ -215,10 +208,9 @@ drawTile ud ctx posanims pr pc row col img =
tileWidth = 64 :: Double
tileHeight = 32 :: Double
filtered = Prelude.filter
(\((V2 ar ac), _) -> floor ar == row && floor ac == col) posanims
(\(V2 ar ac, _) -> floor ar == row && floor ac == col) posanims
sorted = sortOn (\(V2 sr sc, _) -> sc + sr * maxCol) filtered
maxCol = maximum (Prelude.map (\(V2 _ mc, _) -> mc) filtered)
minrs = Prelude.map (fst . matmin) mb
maxrs = Prelude.map (fst . matmax) mb
mincs = Prelude.map (snd . matmin) mb
maxcs = Prelude.map (snd . matmax) mb
@ -257,42 +249,13 @@ drawTile ud ctx posanims pr pc row col img =
fillPaint ctx paint
fill ctx
drawAnims
:: Context
-> Map AnimId Animation
-> SystemState Entity IO
-> [(V2 Double, AnimState)]
-> Double
-> Double
-> Int
-> Int
-> Maybe ImgId
-> IO ()
drawAnims ctx anims ws posanims pr pc r c tile =
mapM_ (\(V2 nr nc, as) -> do
let x = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32
y = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16
anim = anims Map.! asId as
beginPath ctx
paint <- imagePattern ctx (x - 32) (y - 58) 64 74 0
(animSprites anim !! asCurrentFrame as) 1
rect ctx (x - 32) (y - 58) 64 74
fillPaint ctx paint
fill ctx
) filtered
where
filtered = Prelude.filter
(\((V2 ar ac), _) -> floor ar == r && floor ac == c) posanims
sorted = sortOn (\(V2 sr sc, _) -> sc + sr * maxCol) filtered
maxCol = maximum (Prelude.map (\(V2 _ mc, _) -> mc) filtered)
updateMap :: Double -> Affection UserData ()
updateMap dt = do
let direction :: V2 Double -> Direction -> Direction
direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0
then
let xuu =
(acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel'))) / pi * 180
acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel')) / pi * 180
xu = if vr < 0 then 360 - xuu else xuu
d
| xu < 22.5 = NE
@ -304,39 +267,40 @@ updateMap dt = do
| xu > 247.5 && xu < 292.5 = NW
| xu > 292.5 && xu < 337.5 = N
| xu > 337.5 = NE
| otherwise = NE
in d
else rot'
ud <- getAffection
(nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do
emap allEnts $ do
with anim
state <- query anim
let anim = assetAnimations ud Map.! asId state
ntime = asElapsedTime state + dt
nstate = if ntime > (fromIntegral $ asCurrentFrame state) *
(animDuration anim / (fromIntegral $ length $ animSprites anim))
stat <- query anim
let an = assetAnimations ud Map.! asId stat
ntime = asElapsedTime stat + dt
nstate = if ntime > fromIntegral (asCurrentFrame stat) *
(animDuration an / fromIntegral (length $ animSprites an))
then
let nframe = asCurrentFrame state + 1
in case animPlay anim of
let nframe = asCurrentFrame stat + 1
in case animPlay an of
APLoop ->
let (nnframe, nntime) =
if nframe >= (length $ animSprites anim)
if nframe >= length (animSprites an)
then (0, 0)
else (nframe, ntime)
in state
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = nntime
}
APOnce ->
let nnframe = if nframe >= (length $ animSprites anim)
let nnframe = if nframe >= length (animSprites an)
then nframe - 1
else nframe
in state
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = ntime
}
else
state
stat
{ asElapsedTime = ntime
}
return $ unchanged
@ -349,18 +313,17 @@ updateMap dt = do
with pos
with rot
with anim
pos'@(V2 pr pc) <- query pos
pos' <- query pos
vel' <- query vel
rot' <- query rot
fact' <- query velFact
state <- query anim
let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel'
dpos = npos - pos'
aId = asId state
stat <- query anim
let npos = pos' + fmap (* (dt * fact')) vel'
aId = asId stat
ent = unchanged
{ pos = Set $ npos
{ pos = Set npos
, rot = Set $ direction vel' rot'
, anim = Set state
, anim = Set stat
{ asId = aId
{ aiDirection = direction vel' rot'
}
@ -374,12 +337,12 @@ updateMap dt = do
with rot
with anim
pos'@(V2 pr pc) <- query pos
vel'@(V2 vr vc) <- query vel
vel' <- query vel
rot' <- query rot
state <- query anim
let npos@(V2 nr nc) = pos' + fmap (* dt) vel'
stat <- query anim
let npos = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos'
aId = asId state
aId = asId stat
len = sqrt (dpos `dot` dpos)
lll = (,)
<$> (
@ -411,7 +374,7 @@ updateMap dt = do
(A.log A.Verbose (show lll ++ " " ++ show len) lll)
)
, rot = Set (direction vel' rot')
, anim = Set state
, anim = Set stat
{ asId = aId
{ aiDirection = direction vel' rot'
}
@ -437,26 +400,26 @@ checkBoundsCollision2
-> Boundaries Double
-> V2 Double
checkBoundsCollision2
pre@(V2 pr pc) next@(V2 nr nc) dt acc (Boundaries (minr, minc) (maxr, maxc))
pre@(V2 pr pc) nex dt acc (Boundaries (minr, minc) (maxr, maxc))
| colltr < dt && colltc < dt = V2 0 0
| colltr < dt && incol = V2 0 1 * acc
| colltc < dt && inrow = V2 1 0 * acc
| otherwise = acc
where
vel@(V2 vr vc) = fmap (/ dt) (next - pre)
V2 vr vc = fmap (/ dt) (nex - pre)
colltr
| vr > 0 && prr <= maxr =
(((fromIntegral (floor pr :: Int)) + minr - 0.15) - pr) / vr
((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr
| vr < 0 && prr >= minr =
(((fromIntegral (floor pr :: Int)) + maxr + 0.15) - pr) / vr
((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr
| otherwise = dt
colltc
| vc > 0 && prc <= maxc =
(((fromIntegral (floor pc :: Int)) + minc - 0.15) - pc) / vc
((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc
| vc < 0 && prc >= minc =
(((fromIntegral (floor pc :: Int)) + maxc + 0.15) - pc) / vc
((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc
| otherwise = dt
inrow = pr > minr && pr < maxr
incol = pc > minc && pc < maxc
prr = pr - (fromIntegral $ floor pr)
prc = pc - (fromIntegral $ floor pc)
prr = pr - fromIntegral (floor pr :: Int)
prc = pc - fromIntegral (floor pc :: Int)