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

hunting warnings in Test

Browse source
This commit is contained in:
nek0 2018-05-30 17:32:00 +02:00
parent 5c70976678
commit f6db4f5e5c
1 changed files with 55 additions and 92 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

147
src/Test.hs
View file

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