{-# 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.IO.Class (liftIO) 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 (sortOn, partition, find) 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 :: Affection UserData () loadMap = do ud <- getAffection ad <- get let (Subsystems _ m k j t) = subsystems ud uu0 <- partSubscribe k emitKbdActionMessage uu1 <- partSubscribe j emitJoyActionMessage uu2 <- partSubscribe t movePlayer2 uu3 <- partSubscribe t playerInteract2 uu4 <- partSubscribe t changeMaps2 future <- liftIO newEmptyMVar progress <- liftIO $ newMVar (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud ad future progress putAffection ud { stateData = None , uuid = [ uu0, uu1, uu2, uu3, uu4 ] , stateMVar = future , stateProgress = progress , state = Main WorldMap } changeMaps :: KeyboardMessage -> Affection UserData () changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF1 = do ud <- getAffection case state ud of Main MindMap -> putAffection ud { state = Main WorldMap } Main WorldMap -> putAffection ud { state = Main MindMap } _ -> return () | otherwise = return () changeMaps _ = return () changeMaps2 :: ActionMessage -> Affection UserData () changeMaps2 (ActionMessage ActSwitchMap _) = do ud <- getAffection case state ud of Main MindMap -> putAffection ud { state = Main WorldMap } Main WorldMap -> putAffection ud { state = Main MindMap } _ -> return () changeMaps2 _ = return () loadMapFork :: UserData -> AffectionData UserData -> MVar (SystemState Entity (AffectionState (AffectionData UserData) 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)] (50, 50) 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 gr let !rps = ReachPoint Elevator (fcElevator fc) SE 0 : rawrps modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Creating WorldState" ))) (nws, mmimgmat) <- evalStateT (runState (yieldSystemT (worldState ud) $ 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: " ++ 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: " ++ 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: " ++ 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: " ++ 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)) let room = head (Prelude.filter ((inBounds $ pointCoord cpr) . bounds) (Types.connects (head gr) ++ 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 AnimJDoeM "standing" SE) 0 0 } ) computers liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering doors into WorldState" ))) mapM_ (\door -> do let rooms = Prelude.foldl (\acc coord -> let rs = Prelude.filter ((inBounds coord) . bounds) graph in if not (Prelude.null rs) then (coord, head rs) : acc else acc ) [] coords graph = Types.connects (head gr) ++ tail gr coords = Prelude.map (door +) deltas deltas = [ V2 0 1 , V2 1 0 , V2 (-1) 0 , V2 0 (-1) ] wall = Prelude.filter (\delta -> let V2 r c = door + delta 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 (maximum $ 0 : Prelude.map clearance (Prelude.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) putMVar future (nws, MainData { mapMat = mat , imgMat = retMat , reachPoints = rps , mmImgMat = mmimgmat , roomGraph = gr }) movePlayerKbd :: KeyboardMessage -> Affection UserData () movePlayerKbd (MsgKeyboardEvent _ _ press False sym) | SDL.keysymKeycode sym == SDL.KeycodeW = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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 } putAffection ud { worldState = nws } | SDL.keysymKeycode sym == SDL.KeycodeS = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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 } putAffection ud { worldState = nws } | SDL.keysymKeycode sym == SDL.KeycodeA = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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 } putAffection ud { worldState = nws } | SDL.keysymKeycode sym == SDL.KeycodeD = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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 } putAffection ud { worldState = nws } | otherwise = return () movePlayerKbd _ = return () movePlayer2 :: ActionMessage -> Affection UserData () movePlayer2 (ActionMessage mov _) = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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 } putAffection ud { worldState = nws } movePlayer2 _ = return () playerInteract :: MouseMessage -> Affection UserData () playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do ud <- getAffection (V2 rx ry) <- liftIO $ (* V2 640 360) <$> relativizeMouseCoords m let dr = ((ry / 32) / sin (atan 0.5) / 2) + (rx / 64) dc = (rx / 64) - ((ry / 32) / sin (atan 0.5) / 2) (nws, _) <- yieldSystemT (worldState ud) $ do emap allEnts $ do with player with rot rot' <- query rot let ndir = direction (V2 dr dc) return $ unchanged { rot = Set $ fromMaybe rot' ndir } 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) && (fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) && pdir == dir) reldirs then return $ Just (otype, ostate, ent) else return Nothing let relEnts = catMaybes mrelEnts liftIO $ A.logIO A.Debug ("relEnts: " ++ 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 putAffection ud { worldState = nws } playerInteract _ = return () playerInteract2 :: ActionMessage -> Affection UserData () playerInteract2 (ActionMessage ActActivate _) = do ud <- getAffection (nws, _) <- yieldSystemT (worldState ud) $ 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: " ++ 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 putAffection ud { worldState = nws } playerInteract2 _ = return () drawMap :: Affection UserData () drawMap = do ud <- getAffection let ctx = nano ud case stateData ud of None -> liftIO $ do progress <- readMVar (stateProgress ud) drawLoadScreen ud progress _ -> do dt <- getDelta (_, dat) <- yieldSystemT (worldState ud) $ 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 = stateData ud seekGraph = Types.connects (head gr) ++ tail gr room = Prelude.filter (inBounds (fmap floor playerPos) . bounds) seekGraph mat = imgMat (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 $ mapMat $ stateData ud) (ncols $ mapMat $ stateData ud) ((reverse . fst) (Prelude.foldl (\(done, proc) coord -> let (ndone, nproc) = processList proc coord in (ndone : done, nproc) ) ([], posanims) ((,) <$> [1 .. (nrows $ mapMat $ stateData ud)] <*> [1 .. (ncols $ mapMat $ 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 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), tile) -> ((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 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.pack (Prelude.take 5 $ show (1/dt)) <> " Clearance: " <> if not (Prelude.null room) then T.pack (show $ clearance $ head room) else "0" ) 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 save ctx mapM_ drawAnim beh maybe (return ()) (draw ud x (y - 42) 64 74 fact) ((assetImages ud Map.!) <$> case img of Just ImgEmpty -> Nothing _ -> img ) mapM_ drawAnim 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) + (floor $ srow * 100) 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 isWall (fromJust img) && (pr <= fromIntegral row + minimum maxrs && pc >= fromIntegral col + maximum mincs) then min 1 dist else 1 mb = maybe [] collisionObstacle img drawAnim (V2 nr nc, as, _) = do let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 - 32 ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 - 58 draw ud ax ay 64 74 1 as updateMap :: Double -> Affection UserData () updateMap dt = do ud <- getAffection if stateData ud == None then do mstart <- liftIO $ tryTakeMVar (stateMVar ud) case mstart of Just (nws, mendat) -> do putAffection ud { worldState = nws , stateData = mendat , state = Main WorldMap } updateMap 0.1 updateMap 0.1 updateMap 0.1 updateMap 19 liftIO $ logIO A.Debug "Loaded game data" Nothing -> return () else do (nws, _) <- yieldSystemT (worldState ud) $ 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' <- query rot fact' <- fromMaybe 1 <$> queryMaybe velFact xyv2 <- queryMaybe xyvel stat <- query anim let an = assetAnimations ud Map.! asId stat 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 (show ret) ret) (V2 1 1) ( concatMap (\(dr, dc) -> let bs = (++) (maybe [] collisionObstacle (fromMaybe Nothing $ M.safeGet (fromIntegral $ floor pr + dr) (fromIntegral $ floor pc + dc) (imgMat (stateData ud)))) (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) } } x -> 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 allRelEnts dt t s e ) tses (nws2, _) <- yieldSystemT nws $ updateNPCs (imgMat $ stateData ud) nws (Prelude.filter (\p -> pointType p /= RoomExit) (reachPoints $ stateData ud) ) dt putAffection ud { worldState = nws2 }