hunting warnings in Test
This commit is contained in:
nek0
parent
5c70976678
commit
f6db4f5e5c
1 changed files with 55 additions and 92 deletions
147
src/Test.hs
147
src/Test.hs
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue