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)))