{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} module MainGame.WorldMap where import Affection as A import Algebra.Graph as AG hiding (Context(..)) import qualified SDL import NanoVG hiding (V2(..)) import Control.Monad (when, void) import Control.Monad.State.Strict (evalStateT) import Control.Concurrent.MVar import Control.Concurrent (forkIO) import Control.Parallel.Strategies hiding (dot) import Data.Map.Strict as Map import qualified Data.Set as S import qualified Data.Text as T import Data.Matrix as M import Data.Ecstasy as E import Data.Maybe import Data.List as L import qualified Data.Vector as V import Data.String import System.Random (randomRIO) import Linear hiding (E) import Foreign.C.Types (CFloat(..)) -- internal imports import Interior import Util import Types import Floorplan import MindMap import NPC import Animation import Collision loadMap :: UserData -> Affection () loadMap ud = do ad <- get let (Subsystems _ _ k j t) = subsystems ud uu0 <- partSubscribe k (emitKbdActionMessage ud) uu1 <- partSubscribe j (emitJoyActionMessage ud) uu2 <- partSubscribe t (movePlayer2 ud) uu3 <- partSubscribe t (playerInteract2 ud) uu4 <- partSubscribe t (changeMaps2 ud) void $ liftIO $ swapMVar (stateProgress ud) (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud ad (stateMVar ud) (stateProgress ud) void $ liftIO $ swapMVar (stateData ud) None void $ liftIO $ swapMVar (uuid ud) [ uu0, uu1, uu2, uu3, uu4 ] void $ liftIO $ swapMVar (state ud) (Main WorldMap) changeMaps :: UserData -> KeyboardMessage -> Affection () changeMaps ud (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF1 = do curState <- liftIO $ readMVar (state ud) case curState of Main MindMap -> void $ liftIO $ swapMVar (state ud) (Main WorldMap) Main WorldMap -> void $ liftIO $ swapMVar (state ud) (Main MindMap) _ -> return () | otherwise = return () changeMaps _ _ = return () changeMaps2 :: UserData -> ActionMessage -> Affection () changeMaps2 ud (ActionMessage ActSwitchMap _) = do curState <- liftIO $ readMVar (state ud) case curState of Main MindMap -> void $ liftIO $ swapMVar (state ud) (Main WorldMap) Main WorldMap -> void $ liftIO $ swapMVar (state ud) (Main MindMap) _ -> return () changeMaps2 _ _ = return () loadMapFork :: UserData -> AffectionData -> MVar (SystemState Entity (AffectionState AffectionData IO), StateData) -> MVar (Float, T.Text) -> IO () loadMapFork ud ad future progress = do let loadSteps = 23 increment = 1 / loadSteps fc = FloorConfig (V2 10 10) [(V2 5 5), (V2 5 20)] (40, 40) modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Building floor" ))) (mat, gr) <- buildHallFloorIO fc progress increment -- 11 increments inside modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Converting to images" ))) let !imgmat = convertTileToImg mat !doors = Prelude.foldl (\acc coord@(r, c) -> if mat M.! coord == Door then V2 r c : acc else acc ) [] ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) !exits = Prelude.foldl (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty then ReachPoint RoomExit (V2 r c) NE 0 : acc else acc ) [] ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Placing furniture" ))) (!inter, !rawrps) <- placeInteriorIO mat imgmat exits (V.toList gr) let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Creating WorldState" ))) wState <- liftIO $ readMVar (worldState ud) (nws, mmimgmat) <- evalStateT (runState (yieldSystemT wState $ do liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering copiers into WorldState" ))) let !copiers = Prelude.filter (\a -> pointType a == Copier) rps mapM_ (\(ReachPoint _ icoord _ _) -> do let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord void $ createEntity $ newEntity { pos = Just $ reachCoord - V2 1 0 , obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36) , anim = Just $ AnimState (AnimId AnimCopier "open" N) 0 0 , objAccess = Just [(V2 1 0, NW)] , objType = Just ObjCopier , objState = Just "idle" } ) (A.log A.Debug ("number of copiers: " <> fromString (show $ length copiers)) copiers ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering computers into WorldState" ))) let !computers = Prelude.filter ((Computer ==) . pointType) rps mapM_ (\(ReachPoint _ icoord dir _) -> do let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord access = case dir of N -> V2 1 (-1) NE -> V2 0 (-1) NW -> V2 1 0 x -> error ("computer placement " ++ show x ++ " not defined") void $ createEntity $ newEntity { pos = Just $ reachCoord - fmap fromIntegral access , anim = Just $ AnimState (AnimId AnimComputer "off" dir) 0 0 , rot = Just dir , objAccess = Just [(access, dir)] , objType = Just ObjComputer , objState = Just "off" } ) (A.log A.Debug ("number of computers: " <> fromString (show $ length computers)) computers ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering toilets into WorldState" ))) let !toilets = Prelude.filter (\a -> pointType a == Toilet) rps mapM_ (\(ReachPoint _ icoord dir _) -> do let reachCoord = fmap ((+ 0.5) . fromIntegral) icoord void $ createEntity $ newEntity { pos = Just $ reachCoord - V2 0 (-1) , obstacle = Just $ Boundaries (0, 0) (1, 1) , anim = Just $ AnimState (AnimId AnimToilet "free" N) 0 0 , objAccess = Just [(V2 0 (-1), dir)] , objType = Just ObjToilet } ) (A.log A.Debug ("number of toilets: " <> fromString (show $ length toilets)) toilets ) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Preparing MindMap graph" ))) (mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$> buildMindMap (length computers) 2 liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Unfolding and Converting MindMap to images" ))) let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat !pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph)) !delta = (0, 0) : Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)] !mmmpos = Prelude.foldl (\acc (dr, dc) -> let (V2 pmr pmc) = floor <$> pmmpos seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc) in if isNothing (mmimgmat M.! seekpos) && mmintmat M.! seekpos == 0 && isNothing acc then Just (pmmpos + (fromIntegral <$> V2 dr dc)) else acc ) Nothing delta void $ createEntity $ newEntity { pos = Just (V2 10.5 10.5) , mmpos = mmmpos , vel = Just (V2 0 0) , xyvel = Just (V2 0 0) , mmvel = Just (V2 0 0) , player = Just () , rot = Just SE , clearanceLvl = Just 0 , anim = Just $ AnimState (AnimId AnimIntruder "standing" SE) 0 0 } liftIO $ A.logIO A.Debug ("number of placed NPCs: " <> fromString (show $ length computers)) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering NPCs into WorldState" ))) mapM_ (\cpr -> do fact <- liftIO $ randomRIO (0.5, 1.5) stats <- liftIO $ NPCStats <$> (randomRIO (0, 1)) <*> pure 0 <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) police <- liftIO $ randomRIO (0 :: Int, 9 :: Int) let room = V.head (V.filter ((inBounds $ pointCoord cpr) . bounds) (V.fromList $ V.toList (Types.connects (V.head gr)) ++ (V.toList (V.tail gr))) ) void $ createEntity $ newEntity { pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr)) , vel = Just (V2 0 0) , velFact = Just fact , rot = Just SE , npcMoveState = Just (NPCWalking [[pointCoord cpr]]) , npcWorkplace = Just cpr , npcActionState = Just ASWork , npcStats = Just stats , clearanceLvl = Just (clearance room) , anim = Just $ AnimState (AnimId (if police == 0 then AnimPoliceM else AnimJDoeM) "standing" SE) 0 0 } ) computers liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering doors into WorldState" ))) mapM_ (\door -> do let rooms = V.foldl (\acc coord -> let rs = V.filter ((inBounds coord) . bounds) graph in if not (V.null rs) then (coord, V.head rs) `V.cons` acc else acc ) V.empty (V.fromList coords) graph = V.fromList $ (V.toList $ Types.connects (V.head gr)) ++ (V.toList $ V.tail gr) coords = Prelude.map (door +) deltas deltas = [ V2 0 1 , V2 1 0 , V2 (-1) 0 , V2 0 (-1) ] wall = Prelude.filter (\ddelta -> let V2 r c = door + ddelta in fromMaybe False (isWall <$> imgmat M.! (r, c))) deltas orientation | head wall == V2 0 1 || head wall == V2 0 (-1) = NW | head wall == V2 1 0 || head wall == V2 (-1) 0 = NE | otherwise = error ("strange wall: " ++ show wall) void $ createEntity $ newEntity { pos = Just (fmap ((+ 0.5) . fromIntegral) door) , clearanceLvl = Just (V.maximum $ 0 `V.cons` V.map clearance (V.map snd rooms)) , anim = Just $ AnimState (AnimId AnimDoor0 "shut" orientation) 0 1 , obstacle = Just $ case orientation of NW -> Boundaries (4/9, 0) (5/9, 1) NE -> Boundaries (0, 4/9) (1, 5/9) _ -> error "strange orientation for door" , ignoreObstacle = Just () , rot = Just orientation , objAccess = Just $ case orientation of NW -> [ ((V2 (-1) 0), SE) , ((V2 1 0), NW) ] NE -> [ ((V2 0 1), SW) , ((V2 0 (-1)), NE) ] _ -> error "strange orientation for door" , objType = Just ObjDoor , objState = Just "shut" } ) doors liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Handing over" ))) return mmimgmat )) ad let !retMat = M.fromList (nrows inter) (ncols inter) $ Prelude.map (\a -> if a == Just ImgEmpty || a == Just ImgEmptyNoWalk then Nothing else a) (M.toList inter) void $ putMVar future (nws, MainData { mapMat = mat , imgMat = retMat , reachPoints = V.fromList rps , mmImgMat = mmimgmat , roomGraph = gr }) movePlayerKbd :: UserData -> KeyboardMessage -> Affection () movePlayerKbd ud (MsgKeyboardEvent _ _ press False sym) | SDL.keysymKeycode sym == SDL.KeycodeW = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 vx _) <- query xyvel let ry = if (press == SDL.Pressed) then 1 else 0 return $ unchanged { xyvel = Set $ V2 vx ry } void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeS = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 vx _) <- query xyvel let ry = if (press == SDL.Pressed) then -1 else 0 return $ unchanged { xyvel = Set $ V2 vx ry } void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeA = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 _ vy) <- query xyvel let rx = if (press == SDL.Pressed) then -1 else 0 return $ unchanged { xyvel = Set $ V2 rx vy } void $ liftIO $ swapMVar (worldState ud) nws | SDL.keysymKeycode sym == SDL.KeycodeD = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player (V2 _ vy) <- query xyvel let rx = if (press == SDL.Pressed) then 1 else 0 return $ unchanged { xyvel = Set $ V2 rx vy } void $ liftIO $ swapMVar (worldState ud) nws | otherwise = return () movePlayerKbd _ _ = return () movePlayer2 :: UserData -> ActionMessage -> Affection () movePlayer2 ud (ActionMessage mov _) = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ emap allEnts $ do with player V2 vx vy <- query xyvel return $ unchanged { xyvel = Set $ case mov of ActUp f -> V2 vx (-f) ActDown f -> V2 vx f ActLeft f -> V2 (-f) vy ActRight f -> V2 f vy _ -> V2 vx vy } void $ liftIO $ swapMVar (worldState ud) nws playerInteract2 :: UserData -> ActionMessage -> Affection () playerInteract2 ud (ActionMessage ActActivate _) = do wState <- liftIO $ readMVar (worldState ud) (nws, _) <- yieldSystemT wState $ do pdata <- efor allEnts $ do with player with pos with rot pos' <- query pos rot' <- query rot ent <- queryEnt return (pos', rot', ent) let (ppos, pdir, pent) = head pdata mrelEnts <- efor allEnts $ do with pos with objAccess with objType with objState reldirs <- query objAccess pos' <- query pos otype <- query objType ostate <- query objState ent <- queryEnt if any (\(rel, dir) -> ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) || (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) && pdir == dir) reldirs then return $ Just (otype, ostate, ent) else return Nothing let relEnts = catMaybes mrelEnts liftIO $ A.logIO A.Debug ("relEnts: " <> fromString (show relEnts)) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) mapM_ (\(t, s, e) -> setEntity e =<< objectTransition t s True e (Just pent) ) relEnts void $ liftIO $ swapMVar (worldState ud) nws playerInteract2 _ _ = return () drawMap :: UserData -> Affection () drawMap ud = do sData <- liftIO $ readMVar (stateData ud) wState <- liftIO $ readMVar (worldState ud) let ctx = nano ud case sData of None -> liftIO $ do progress <- readMVar (stateProgress ud) drawLoadScreen ud progress _ -> do dt <- getDelta (_, dat) <- yieldSystemT wState $ do efor allEnts $ do with pos pos' <- query pos player' <- queryMaybe player stat <- queryMaybe anim mbnds <- queryMaybe obstacle t <- queryMaybe objType s <- queryMaybe objState pa <- queryMaybe objPlayerActivated ttl <- queryMaybe objStateTime let maxt = fromMaybe 1 (actionTime <$> t <*> s) first = if isJust player' then Just pos' else Nothing secnd = if isJust stat then Just ( pos' , fromJust stat , mbnds ) else Nothing third = if isJust t && isJust s then Just ( pos' , fromMaybe False pa , realToFrac (1 - fromMaybe 0 ttl / maxt) ) else Nothing return (first, secnd, third) let ((playerPos:_), posanims, posActions) = Prelude.foldl (\(amppo, ampan, ampac) (mppo, mpan, mpac) -> ( if isJust mppo then fromJust mppo : amppo else amppo , if isJust mpan then fromJust mpan : ampan else ampan , if isJust mpac then fromJust mpac : ampac else ampac ) ) ([], [], []) dat V2 pr pc = playerPos MainData _ _ _ _ gr = sData seekGraph = V.foldl V.snoc (Types.connects (V.head gr)) (V.tail gr) room = V.filter (inBounds (fmap floor playerPos) . bounds) seekGraph mat = imgMat sData 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 $ mapMat sData) (ncols $ mapMat sData) ((reverse . fst) (Prelude.foldl (\(done, proc) coord -> let (ndone, nproc) = processList proc coord in (ndone : done, nproc) ) ([], posanims) ((,) <$> [1 .. (nrows $ mapMat sData)] <*> [1 .. (ncols $ mapMat sData)] ) ) ) 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 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 let coordList = concatMap (\(i, ls) -> Prelude.map (\(j, t) -> ((i, j), t)) (reverse $ zip [1..] ls) ) (zip [1..] (toLists mat)) filterList = Prelude.filter (\((frow, fcol), _) -> ((realToFrac (sx frow fcol) > -tileWidth && realToFrac (sy frow fcol) > -tileHeight) && ((realToFrac (sx frow fcol) :: Double) < 1280 && (realToFrac ((sy frow fcol)- (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) ) coordList !posanimList = Prelude.map (\((row, col), tile) -> ((row, col), tile, partposanims M.! (row, col))) filterList sx row col = realToFrac $ 640 + ((fromIntegral col - pc) + (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat sy row col = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat void $ sequence $ parMap rpar -- mapM_ (\((row, col), tile, posanim) -> drawTile ud ctx posanim pr pc row col tile ) posanimList -- void $ sequence $ parMap rpar (\(i, ls) -> void $ sequence $ parMap rpar -- (\(j, t) -> drawTile ud ctx (partposanims M.! (i, j)) pr pc i j t) -- (reverse $ zip [1..] ls)) -- (zip [1..] (toLists mat)) mapM_ (\(V2 sr sc, pa, perc) -> when pa $ do let lx = realToFrac $ 640 + ((sc - pc) + (sr - pr)) * (tileWidth / 2) :: CFloat ly = realToFrac $ 360 - (tileHeight / 2) + ((sr - pr) - (sc - pc)) * (tileHeight / 2) :: CFloat fillColor ctx (rgb 0 255 0) strokeColor ctx (rgb 0 255 0) strokeWidth ctx 2 beginPath ctx rect ctx (lx - 25) (ly - 50) 50 10 stroke ctx closePath ctx beginPath ctx rect ctx (lx - 25 * perc) (ly - 50) (50 * perc) 10 fill ctx closePath ctx ) posActions fontSize ctx 20 aFonts <- readMVar (assetFonts ud) fontFace ctx (aFonts Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter,AlignTop]) fillColor ctx (rgb 255 128 0) textBox ctx 0 0 200 ( "FPS: " <> T.pack (Prelude.take 5 $ show (1/dt)) <> " Clearance: " <> (if not (Prelude.null room) then T.pack (show $ clearance $ V.head room) else "0" ) <> "\nFor answers call 6350" ) drawTile :: UserData -> Context -> [(V2 Double, AnimState, Maybe (Boundaries Double))] -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO () drawTile ud ctx posanims pr pc row col img = do let (bef, beh) = L.partition delimiter sorted aImages <- readMVar (assetImages ud) save ctx mapM_ (flip drawAnim fact) beh maybe (return ()) (Types.draw ud x (y - 42) 64 74 (if fromMaybe False (isWall <$> img) then fact else 1)) ((aImages Map.!) <$> case img of Just ImgEmpty -> Nothing _ -> img ) mapM_ (flip drawAnim fact) bef restore ctx -- when (floor pr == row && floor pc == col) $ do -- A.logIO A.Debug ("sorted: " ++ show sorted) -- A.logIO A.Debug ("beh: " ++ show beh) -- A.logIO A.Debug ("bef: " ++ show bef) where delimiter (V2 nr nc, as, mbnds) = animFloats (asId as) || all delimit mb where delimit b | nnr > fst (matmax b) || nnc < snd (matmin b) = True | nnr > fst (matmin b) && nnr < fst (matmax b) = nnc <= snd (matmin b) | nnc > snd (matmin b) && nnc < snd (matmax b) = nnr >= fst (matmax b) | otherwise = False nnr = case mbnds of Just (Boundaries (_, _) (maxr, _)) -> maxr Nothing -> nr - fromIntegral ((floor nr) :: Int) :: Double nnc = case mbnds of Just (Boundaries (_, minc) (_, _)) -> minc Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double tileWidth = 64 :: Double tileHeight = 32 :: Double sorted = sortOn (\(V2 sr sc, _, mbnds) -> let comp srow scol = ((floor $ (1 - scol) * 100) :: Int) + ((floor $ srow * 100) :: Int) in case mbnds of Just (Boundaries (minr, minc) (maxr, maxc)) -> comp (minr + ((maxr - minr) / 2)) (minc + (maxc - minc) / 2) _ -> comp (sr - (fromIntegral ((floor sr) :: Int))) (sc - (fromIntegral ((floor sc) :: Int))) ) posanims minrs = Prelude.map (fst . matmin) mb maxrs = Prelude.map (fst . matmax) mb mincs = Prelude.map (snd . matmin) mb maxcs = Prelude.map (snd . matmax) mb x = realToFrac $ 640 + ((fromIntegral col - pc) + (fromIntegral row - pr)) * (tileWidth / 2) :: CFloat y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - (fromIntegral col - pc)) * (tileHeight / 2) :: CFloat dist = distance (V2 (fromIntegral row) (fromIntegral col)) (V2 (realToFrac pr - 1) (realToFrac pc)) / 4 fact = if pr <= fromIntegral row + (if L.null maxrs then 0.5 else minimum maxrs) && pc >= fromIntegral col + (if L.null mincs then 0.5 else maximum mincs) then min 1 dist else 1 mb = maybe [] collisionObstacle img drawAnim (V2 nr nc, as, _) factor = do let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32 ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58 Types.draw ud ax ay 64 74 (if isWallLike (aiVariation $ asId as) then factor else 1) as updateMap :: UserData -> Double -> Affection () updateMap ud dt = do osData <- liftIO $ readMVar (stateData ud) if osData == None then do mstart <- liftIO $ tryTakeMVar (stateMVar ud) case mstart of Just (nws, mendat) -> do void $ liftIO $ swapMVar (worldState ud) nws void $ liftIO $ swapMVar (stateData ud) mendat void $ liftIO $ swapMVar (state ud) (Main WorldMap) updateMap ud 0.1 updateMap ud 0.1 updateMap ud 0.1 updateMap ud 19 liftIO $ logIO A.Debug "Loaded game data" Nothing -> return () else do wState <- liftIO $ readMVar (worldState ud) sData <- liftIO $ readMVar (stateData ud) aAnim <- liftIO $ readMVar (assetAnimations ud) (nws, _) <- yieldSystemT wState $ do obstacleBounds <- efor allEnts $ do with obstacle with pos b <- query obstacle pos' <- query pos return (pos', b) emap allEnts $ do pos'@(V2 pr pc) <- query pos vel' <- queryMaybe vel rot' <- fromMaybe N <$> queryMaybe rot fact' <- fromMaybe 1 <$> queryMaybe velFact xyv2 <- queryMaybe xyvel stat <- query anim let an = aAnim Map.! asId stat mat = mapMat sData ntime = asElapsedTime stat + dt npos = pos' + fmap (* (dt * fact')) (fromMaybe (V2 0 0) vel') dpos@(V2 dpr dpc) = npos - pos' aId = asId stat 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) ( nub $ concatMap (\(dr, dc) -> let bs = (++) (fromMaybe [] $ collisionObstacle <$> M.unsafeGet (min (nrows mat) $ max 1 $ fromIntegral $ floor pr + dr) (min (ncols mat) $ max 1 $ fromIntegral $ floor pc + dc) (imgMat sData)) (Prelude.map snd $ Prelude.filter (\((V2 br bc), _) -> floor pr + dr == floor br && floor pc + dc == floor bc ) obstacleBounds) 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) ) nstate = let velo = fromMaybe (V2 0 0) vel' nstat = if ntime > fromIntegral (asCurrentFrame stat + 1) * (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 } in case aiName aId of "walking" | sqrt (velo `dot` velo) > 0 -> nstat { asId = aId { aiDirection = fromMaybe rot' (direction velo) } } | otherwise -> nstat { asId = aId { aiDirection = fromMaybe rot' (direction velo) , aiName = "standing" } , asCurrentFrame = 0 } "standing" | sqrt (velo `dot` velo) > 0 -> nstat { asId = aId { aiDirection = fromMaybe rot' (direction velo) , aiName = "walking" } , asCurrentFrame = 0 } | otherwise -> nstat { asId = aId { aiDirection = fromMaybe rot' (direction velo) } } _ -> nstat ent = unchanged { pos = Set $ pos' + colldpos , rot = Set $ fromMaybe rot' (direction (fromMaybe (V2 0 0) vel')) , anim = Set nstate , vel = case xyv2 of Just (V2 rx ry) -> let V2 dr dc = fmap (* 1.5) (V2 rx ry `rotVec` 45) in Set $ 2 * V2 dr dc Nothing -> Keep } return ent -- allRelEnts <- efor allEnts $ do -- with pos -- with rot -- with clearanceLvl -- without objType -- pos' <- query pos -- rot' <- query rot -- clvl <- query clearanceLvl -- entn <- queryEnt -- return (entn, pos', rot', clvl) tses <- efor allEnts $ do with objType with objState t <- query objType s <- query objState e <- queryEnt return (t, s, e) mapM_ (\(t, s, e) -> objectAction dt t s e ) tses (nws2, _) <- yieldSystemT nws $ updateNPCs (imgMat sData) (mapMat sData) nws (V.filter (\p -> pointType p /= RoomExit) (reachPoints sData) ) dt void $ liftIO $ swapMVar (worldState ud) nws2