{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} module MainGame.WorldMap where import Affection as A import Algebra.Graph as AG import qualified SDL import NanoVG hiding (V2(..)) import Control.Monad (when, void) import Control.Monad.IO.Class (liftIO) import Control.Concurrent.MVar import Control.Concurrent (forkIO) 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 Object loadMap :: Affection UserData () loadMap = do ud <- getAffection let (Subsystems _ m k) = subsystems ud uu1 <- partSubscribe m movePlayer uu2 <- partSubscribe k changeMaps uu3 <- partSubscribe m playerInteract future <- liftIO newEmptyMVar progress <- liftIO $ newMVar (0, "Ohai!") _ <- liftIO $ forkIO $ loadMapFork ud future progress putAffection ud { stateData = None , uuid = [uu1, uu2, uu3] , stateMVar = future , stateProgress = progress } changeMaps :: KeyboardMessage -> Affection UserData () changeMaps (MsgKeyboardEvent _ _ SDL.Pressed False sym) | SDL.keysymKeycode sym == SDL.KeycodeF1 = do ud <- getAffection putAffection ud { state = Main WorldMap } | SDL.keysymKeycode sym == SDL.KeycodeF2 = do ud <- getAffection putAffection ud { state = Main MindMap } | otherwise = return () changeMaps _ = return () loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> MVar (Float, T.Text) -> IO () loadMapFork ud future progress = do let loadSteps = 19 fc = FloorConfig (10, 10) [(5, 5), (5, 45)] (50, 50) _ <- liftIO $ swapMVar progress (1 / loadSteps, "Building floor") (mat, gr) <- buildHallFloorIO fc progress (1 / loadSteps) _ <- liftIO $ swapMVar progress (11 / loadSteps, "Converting to images") let imgmat = convertTileToImg mat exits = Prelude.foldl (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty then ReachPoint RoomExit (V2 r c) NE : acc else acc ) [] ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) _ <- liftIO $ swapMVar progress (12 / loadSteps, "Placing furniture") (inter, rps) <- placeInteriorIO mat imgmat exits gr _ <- liftIO $ swapMVar progress (13 / loadSteps, "Placing NPCs") logIO A.Debug ("number of reachpoints: " ++ show (length rps)) let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps npcposs <- placeNPCs inter mat rps 10 -- (length $ filter (\a -> pointType a == Table) nnex) _ <- liftIO $ swapMVar progress (14 / loadSteps, "Preparing MindMap graph") A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) !(mmintmat, mmgraph) <- buildFloorMap . springField <$> buildMindMap (length npcposs) 2 _ <- liftIO $ swapMVar progress (15 / loadSteps, "Unfolding and Converting MindMap to images") let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat _ <- liftIO $ swapMVar progress (16 / loadSteps, "Creating WorldState") (nws, _) <- yieldSystemT (worldState ud) $ do let 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) , mmvel = Just (V2 0 0) , player = Just () , rot = Just SE , anim = Just $ AnimState (AnimId "intruder" "standing" SE) 0 0 } void $ liftIO $ swapMVar progress (17 / loadSteps, "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 "copier" "open" N) 0 0 , objAccess = Just $ (V2 1 0, NW) , objType = Just ObjCopier } ) (A.log A.Debug ("number of copiers: " ++ show (length copiers)) copiers) void $ liftIO $ swapMVar progress (18 / loadSteps, "Registering NPCs into WorldState") posbounds <- efor allEnts $ do with pos with obstacle pos' <- query pos bnds <- query obstacle return (pos', bnds) mapM_ (\npcpos@(V2 nr nc) -> do fact <- liftIO $ randomRIO (0.5, 1.5) fut <- liftIO newEmptyMVar _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) fut nnex inter posbounds void $ createEntity $ newEntity { pos = Just (V2 (nr + 0.5) (nc + 0.5)) , vel = Just (V2 0 0) , velFact = Just fact , rot = Just SE , npcMoveState = Just (NPCStanding 0 fut) , anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0 } ) npcposs void $ liftIO $ swapMVar progress (19 / loadSteps, "Handing over") putMVar future (nws, MainData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ Prelude.map (\a -> if a == Just ImgEmpty || a == Just ImgEmptyNoWalk then Nothing else a) (M.toList inter) , reachPoints = rps , mmImgMat = mmimgmat }) mouseToPlayer :: V2 Int32 -> Affection UserData () mouseToPlayer mv2 = do ud <- getAffection (V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 let dr = (ry / sin (atan (1/2)) / 2) + rx dc = rx - (ry / sin (atan (1/2)) / 2) (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ emap allEnts $ do with player pure $ unchanged { vel = Set $ 4 * V2 dr dc } putAffection ud { worldState = nws } movePlayer :: MouseMessage -> Affection UserData () movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] m _) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonLeft _ m) = mouseToPlayer m movePlayer (MsgMouseButton _ _ SDL.Released _ SDL.ButtonLeft _ _) = do ud <- getAffection (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ emap allEnts $ do with player pure $ unchanged { vel = Set $ V2 0 0 } putAffection ud { worldState = nws } movePlayer _ = return () playerInteract :: MouseMessage -> Affection UserData () playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do ud <- getAffection (V2 rx ry) <- liftIO $ relativizeMouseCoords m let dr = (ry / sin (atan 0.5) / 2) + rx dc = rx - (ry / sin (atan 0.5) / 2) (nws, relEnts) <- liftIO $ 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 } [(ppos, pdir)] <- efor allEnts $ do with player with pos with rot pos' <- query pos rot' <- query rot return (pos', rot') mrelEnts <- efor allEnts $ do with pos with objAccess (rel, dir) <- query objAccess pos' <- query pos otype <- query objType ent <- queryEnt if (fmap floor ppos == fmap floor pos' || fmap floor ppos == fmap floor pos' + rel) && pdir == dir then return $ Just (otype, ent) else return Nothing return (catMaybes mrelEnts) liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts) putAffection ud { worldState = nws } mapM_ (uncurry objectAction) relEnts playerInteract _ = 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 (_, (playerPos, posanims)) <- liftIO $ yieldSystemT (worldState ud) $ do pc <- fmap head $ efor allEnts $ do with player with pos query pos posanims <- efor allEnts $ do with anim with pos stat <- query anim pos' <- query pos mbnds <- queryMaybe obstacle return (pos', stat, mbnds) return (pc, posanims) let V2 pr pc = playerPos 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 -- 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))) 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 = when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && ((realToFrac x :: Double) < 1280 && (realToFrac (y - (74 - (realToFrac tileHeight :: CFloat))) :: Double) < 720)) $ 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, _, mbnds) = all delimit mb where delimit b | 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 = True nnr = case mbnds of Just (Boundaries (minr, minc) (maxr, maxc)) -> maxr Nothing -> nr - fromIntegral ((floor nr) :: Int) :: Double nnc = case mbnds of Just (Boundaries (minr, minc) (maxr, maxc)) -> minc Nothing -> nc - fromIntegral ((floor nc) :: Int) :: Double -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs && -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs tileWidth = 64 :: Double tileHeight = 32 :: Double sorted = sortOn (\(V2 sr sc, _, mbnds) -> case mbnds of Just (Boundaries (minr, minc) (maxr, maxc)) -> maxr * 10 + (1 - minc) _ -> (sr - (fromIntegral ((floor sr) :: Int))) * 10 + (1 - (sc - (fromIntegral ((floor sc) :: Int)))) ) posanims -- sorted = 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 + minimum maxrs && pc >= fromIntegral col + maximum mincs) && isWall (fromJust img) 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 isFut <- liftIO $ isEmptyMVar (stateMVar ud) if not isFut && stateData ud == None then do liftIO $ logIO A.Debug "Loaded game data" Just (nws, mendat) <- liftIO $ tryTakeMVar (stateMVar ud) putAffection ud { worldState = nws , stateData = mendat } else do (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do emap allEnts $ do with anim 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 without player with vel with velFact with pos with rot with anim pos' <- query pos vel' <- query vel rot' <- query rot fact' <- query velFact stat <- query anim let npos = pos' + fmap (* (dt * fact')) vel' aId = asId stat nstat = case aiName aId of "walking" | sqrt (vel' `dot` vel') > 0 -> stat { asId = aId { aiDirection = fromMaybe rot' (direction vel') } } | otherwise -> stat { asId = aId { aiDirection = fromMaybe rot' (direction vel') , aiName = "standing" } , asCurrentFrame = 0 } "standing" | sqrt (vel' `dot` vel') > 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) ent = unchanged { pos = Set npos , rot = Set $ fromMaybe rot' (direction vel') , anim = Set nstat } return ent obstacleBounds <- efor allEnts $ do with obstacle with pos b <- query obstacle pos' <- query pos return (pos', b) emap allEnts $ do with player with vel with pos with rot with anim pos'@(V2 pr pc) <- query pos vel' <- query vel 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 (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) ) ent = unchanged { pos = Set $ pos' + colldpos , rot = Set (fromMaybe rot' $ direction vel') , anim = Set nstat } -- liftIO $ A.logIO A.Debug ("player position: " ++ show (pos' + colldpos)) return ent updateNPCs (imgMat $ stateData ud) (Prelude.filter (\p -> pointType p /= RoomExit) (reachPoints $ stateData ud) ) dt putAffection ud { worldState = nws } checkBoundsCollision2 :: V2 Double -> V2 Double -> Double -> V2 Double -> Boundaries Double -> V2 Double checkBoundsCollision2 pre@(V2 pr pc) nex dt acc (Boundaries (minr, minc) (maxr, maxc)) | colltr < dt && colltc < dt = V2 0 0 | colltr < dt && incol = V2 0 1 * acc | colltc < dt && inrow = V2 1 0 * acc | otherwise = acc where V2 vr vc = fmap (/ dt) (nex - pre) colltr | vr > 0 && prr <= maxr = ((fromIntegral (floor pr :: Int) + minr - 0.15) - pr) / vr | vr < 0 && prr >= minr = ((fromIntegral (floor pr :: Int) + maxr + 0.15) - pr) / vr | otherwise = dt colltc | vc > 0 && prc <= maxc = ((fromIntegral (floor pc :: Int) + minc - 0.15) - pc) / vc | vc < 0 && prc >= minc = ((fromIntegral (floor pc :: Int) + maxc + 0.15) - pc) / vc | otherwise = dt inrow = pr > minr && pr < maxr incol = pc > minc && pc < maxc prr = pr - fromIntegral (floor pr :: Int) prc = pc - fromIntegral (floor pc :: Int)