tracer/src/MainGame/MindMap.hs
2019-10-28 18:20:34 +01:00

237 lines
7.4 KiB
Haskell

module MainGame.MindMap where
import Affection as A
import Linear hiding (E(..))
import qualified Data.Map.Strict as Map
import Data.Matrix as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.List as L
import Data.Ecstasy as E
import Data.Maybe
import Data.String
import NanoVG hiding (V2(..))
-- internal imports
import Types
import MainGame.WorldMap (drawTile)
import Collision
import Util
updateMind :: Double -> Affection UserData ()
updateMind dt = do
ud <- getAffection
(nws, _) <- yieldSystemT (worldState ud) $ do
emap allEnts $ do
with player
with xyvel
with mmvel
V2 rx ry <- query xyvel
-- let dr = (ry / sin (atan (1/2)) / 2) + rx
-- dc = rx - (ry / sin (atan (1/2)) / 2)
let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45)
return $ unchanged
{ mmvel = Set $ 2 * V2 dr dc
}
emap allEnts $ do
with anim
with mmpos
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 stat + 1
in case animPlay an of
APLoop ->
let (nnframe, nntime) =
if nframe >= length (animSprites an)
then (0, 0)
else (nframe, ntime)
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = nntime
}
APOnce ->
let nnframe = if nframe >= length (animSprites an)
then nframe - 1
else nframe
in stat
{ asCurrentFrame = nnframe
, asElapsedTime = ntime
}
else
stat
{ asElapsedTime = ntime
}
return $ unchanged
{ anim = Set nstate
}
emap allEnts $ do
with player
with mmvel
with mmpos
with rot
with anim
pos'@(V2 pr pc) <- query mmpos
vel' <- query mmvel
rot' <- query rot
stat <- query anim
let npos = pos' + fmap (* dt) vel'
dpos@(V2 dpr dpc) = npos - pos'
aId = asId stat
nstat = case aiName aId of
"walking"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "standing"
}
, asCurrentFrame = 0
}
"standing"
| sqrt (colldpos `dot` colldpos) > 0 ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
, aiName = "walking"
}
, asCurrentFrame = 0
}
| otherwise ->
stat
{ asId = aId
{ aiDirection = fromMaybe rot' (direction vel')
}
}
x -> error ("unknown animation name" ++ x)
lll = (,)
<$> (
if dpr < 0
then [(floor dpr :: Int) .. 0]
else [0 .. (ceiling dpr :: Int)])
<*> (
if dpc < 0
then [(floor dpc :: Int) .. 0]
else [0 .. (ceiling dpc :: Int)])
colldpos = dpos * Prelude.foldl
(\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a
in A.log A.Verbose (fromString $ show ret) ret)
(V2 1 1)
(
concatMap
(\(dr, dc) ->
let bs = fromMaybe [] $ collisionObstacle <$> M.unsafeGet
(fromIntegral $ floor pr + dr)
(fromIntegral $ floor pc + dc)
(mmImgMat (stateData ud))
in Prelude.map (\(Boundaries (minr, minc) (maxr, maxc))->
Boundaries
(minr + fromIntegral dr, minc + fromIntegral dc)
(maxr + fromIntegral dr, maxc + fromIntegral dc)
) bs
)
lll -- (A.log A.Verbose (show lll ++ " " ++ show len) lll)
)
ent = unchanged
{ mmpos = Set $ pos' + colldpos
, rot = Set (fromMaybe rot' $ direction vel')
, anim = Set nstat
}
return ent
putAffection ud
{ worldState = nws
}
drawMind :: Affection UserData ()
drawMind = do
ud <- getAffection
let ctx = nano ud
dt <- getDelta
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
pc <- fmap head $ efor allEnts $ do
with player
with mmpos
query mmpos
posanims <- efor allEnts $ do
with anim
with mmpos
stat <- query anim
pos' <- query mmpos
mbnds <- queryMaybe obstacle
return (pos', stat, mbnds)
return (pc, posanims)
let V2 pr pc = playerPos
mat = mmImgMat (stateData ud)
cols = fromIntegral (ncols mat)
rows = fromIntegral (nrows mat)
tileWidth = 64 :: Double
tileHeight = 32 :: Double
x = realToFrac $ 640 + ((1 - pc) + (1 - pr)) * (tileWidth / 2)
y = realToFrac $ 360 + ((1 - pr) - (1 - pc)) * (tileHeight / 2)
partposanims = M.fromList
(nrows $ mmImgMat $ stateData ud)
(ncols $ mmImgMat $ stateData ud)
((reverse . fst)
(Prelude.foldl
(\(done, proc) coord ->
let (ndone, nproc) = processList proc coord
in (ndone : done, nproc)
)
([], posanims)
((,)
<$> [1 .. (nrows $ mmImgMat $ stateData ud)]
<*> [1 .. (ncols $ mmImgMat $ stateData ud)]
)
)
)
processList
:: [(V2 Double, AnimState, Maybe (Boundaries Double))]
-> (Int, Int)
-> ( [(V2 Double, AnimState, Maybe (Boundaries Double))]
, [(V2 Double, AnimState, Maybe (Boundaries Double))]
)
processList list (r, c) =
let delimiter (V2 nr nc, _, _) =
floor nr == r && floor nc == c
in L.partition delimiter list
liftIO $ do -- draw floor
beginPath ctx
moveTo ctx (x + realToFrac tileWidth / 2) y
lineTo ctx
(x + cols * (realToFrac tileWidth / 2))
(y - (realToFrac tileHeight / 2) * (cols - 1))
lineTo ctx
(x + (realToFrac tileWidth / 2) * (cols + rows - 1))
(y + (rows - cols) * (realToFrac tileHeight / 2))
lineTo ctx
(x + (realToFrac tileWidth / 2) * rows)
(y + (realToFrac tileHeight / 2) * (rows - 1))
closePath ctx
fillColor ctx (rgb 255 255 255)
fill ctx
mapM_ (\(i, ls) -> mapM_
(\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t)
(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)))