2018-06-28 19:07:58 +00:00
|
|
|
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 NanoVG hiding (V2(..))
|
|
|
|
|
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Types
|
|
|
|
|
2019-02-15 19:01:14 +00:00
|
|
|
import MainGame.WorldMap (drawTile)
|
|
|
|
|
|
|
|
import Collision
|
2018-06-28 19:07:58 +00:00
|
|
|
|
2018-11-16 06:12:27 +00:00
|
|
|
import Util
|
2018-07-06 15:17:57 +00:00
|
|
|
|
2018-06-28 19:07:58 +00:00
|
|
|
updateMind :: Double -> Affection UserData ()
|
|
|
|
updateMind dt = do
|
|
|
|
ud <- getAffection
|
2018-08-10 06:58:26 +00:00
|
|
|
(nws, _) <- yieldSystemT (worldState ud) $ do
|
2018-10-13 18:12:10 +00:00
|
|
|
emap allEnts $ do
|
|
|
|
with player
|
|
|
|
with xyvel
|
|
|
|
with mmvel
|
|
|
|
V2 rx ry <- query xyvel
|
2018-11-16 06:12:27 +00:00
|
|
|
-- 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)
|
2018-10-13 18:12:10 +00:00
|
|
|
return $ unchanged
|
|
|
|
{ mmvel = Set $ 2 * V2 dr dc
|
|
|
|
}
|
2018-06-28 19:07:58 +00:00
|
|
|
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
|
2018-07-06 15:18:12 +00:00
|
|
|
with rot
|
2018-06-28 19:07:58 +00:00
|
|
|
with anim
|
|
|
|
pos'@(V2 pr pc) <- query mmpos
|
2018-10-13 18:12:10 +00:00
|
|
|
vel' <- query mmvel
|
2018-06-28 19:07:58 +00:00
|
|
|
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
|
2018-07-06 15:17:57 +00:00
|
|
|
{ aiDirection = fromMaybe rot' (direction vel')
|
2018-06-28 19:07:58 +00:00
|
|
|
}
|
|
|
|
}
|
|
|
|
| otherwise ->
|
|
|
|
stat
|
|
|
|
{ asId = aId
|
2018-07-06 15:17:57 +00:00
|
|
|
{ aiDirection = fromMaybe rot' (direction vel')
|
2018-06-28 19:07:58 +00:00
|
|
|
, aiName = "standing"
|
|
|
|
}
|
|
|
|
, asCurrentFrame = 0
|
|
|
|
}
|
|
|
|
"standing"
|
|
|
|
| sqrt (colldpos `dot` colldpos) > 0 ->
|
|
|
|
stat
|
|
|
|
{ asId = aId
|
2018-07-06 15:17:57 +00:00
|
|
|
{ aiDirection = fromMaybe rot' (direction vel')
|
2018-06-28 19:07:58 +00:00
|
|
|
, aiName = "walking"
|
|
|
|
}
|
|
|
|
, asCurrentFrame = 0
|
|
|
|
}
|
|
|
|
| otherwise ->
|
|
|
|
stat
|
|
|
|
{ asId = aId
|
2018-07-06 15:17:57 +00:00
|
|
|
{ aiDirection = fromMaybe rot' (direction vel')
|
2018-06-28 19:07:58 +00:00
|
|
|
}
|
|
|
|
}
|
|
|
|
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 (show ret) ret)
|
|
|
|
(V2 1 1)
|
|
|
|
(
|
|
|
|
concatMap
|
|
|
|
(\(dr, dc) ->
|
2018-07-03 00:20:17 +00:00
|
|
|
let bs = maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet
|
2018-06-28 19:07:58 +00:00
|
|
|
(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
|
2018-07-06 15:17:57 +00:00
|
|
|
, rot = Set (fromMaybe rot' $ direction vel')
|
2018-06-28 19:07:58 +00:00
|
|
|
, anim = Set nstat
|
|
|
|
}
|
|
|
|
return ent
|
|
|
|
putAffection ud
|
|
|
|
{ worldState = nws
|
|
|
|
}
|
|
|
|
|
|
|
|
drawMind :: Affection UserData ()
|
|
|
|
drawMind = do
|
|
|
|
ud <- getAffection
|
|
|
|
let ctx = nano ud
|
|
|
|
dt <- getDelta
|
2018-08-10 06:58:26 +00:00
|
|
|
(_, (playerPos, posanims)) <- yieldSystemT (worldState ud) $ do
|
2018-06-28 19:07:58 +00:00
|
|
|
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
|
2018-07-21 04:43:26 +00:00
|
|
|
mbnds <- queryMaybe obstacle
|
|
|
|
return (pos', stat, mbnds)
|
2018-06-28 19:07:58 +00:00
|
|
|
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
|
2018-08-19 16:08:13 +00:00
|
|
|
(nrows $ mmImgMat $ stateData ud)
|
|
|
|
(ncols $ mmImgMat $ stateData ud)
|
2018-06-28 19:07:58 +00:00
|
|
|
((reverse . fst)
|
|
|
|
(Prelude.foldl
|
|
|
|
(\(done, proc) coord ->
|
|
|
|
let (ndone, nproc) = processList proc coord
|
|
|
|
in (ndone : done, nproc)
|
|
|
|
)
|
|
|
|
([], posanims)
|
|
|
|
((,)
|
2018-08-19 16:08:13 +00:00
|
|
|
<$> [1 .. (nrows $ mmImgMat $ stateData ud)]
|
|
|
|
<*> [1 .. (ncols $ mmImgMat $ stateData ud)]
|
2018-06-28 19:07:58 +00:00
|
|
|
)
|
|
|
|
)
|
|
|
|
)
|
|
|
|
processList
|
2018-07-21 04:43:26 +00:00
|
|
|
:: [(V2 Double, AnimState, Maybe (Boundaries Double))]
|
2018-06-28 19:07:58 +00:00
|
|
|
-> (Int, Int)
|
2018-07-21 04:43:26 +00:00
|
|
|
-> ( [(V2 Double, AnimState, Maybe (Boundaries Double))]
|
|
|
|
, [(V2 Double, AnimState, Maybe (Boundaries Double))]
|
|
|
|
)
|
2018-07-03 14:19:27 +00:00
|
|
|
processList list (r, c) =
|
2018-07-21 04:43:26 +00:00
|
|
|
let delimiter (V2 nr nc, _, _) =
|
2018-06-28 19:07:58 +00:00
|
|
|
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)))
|