{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} 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 loadMap :: Affection UserData () loadMap = do ud <- getAffection let (Subsystems _ m k) = subsystems ud uu1 <- partSubscribe m movePlayer uu2 <- partSubscribe k changeMaps future <- liftIO newEmptyMVar progress <- liftIO $ newMVar 0 _ <- liftIO $ forkIO $ loadMapFork ud future progress putAffection ud { stateData = None , uuid = [uu1, uu2] , 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 -> IO () loadMapFork ud future progress = do let loadSteps = 18 fc = FloorConfig (10, 10) [(5, 5), (5, 45)] (50, 50) _ <- liftIO $ swapMVar progress (1 / loadSteps) (mat, gr) <- buildHallFloorIO fc progress (1 / loadSteps) _ <- liftIO $ swapMVar progress (11 / loadSteps) 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) (inter, rps) <- placeInteriorIO mat imgmat exits gr _ <- liftIO $ swapMVar progress (13 / loadSteps) logIO A.Debug ("number of reachpoints: " ++ show (length rps)) let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps npcposs <- placeNPCs inter mat rps 50 -- (length nnex) _ <- liftIO $ swapMVar progress (14 / loadSteps) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) (mmintmat, mmgraph) <- buildFloorMap . springField <$> buildMindMap (length npcposs) 3 _ <- liftIO $ swapMVar progress (15 / loadSteps) let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat _ <- liftIO $ swapMVar progress (16 / loadSteps) (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 , mmrot = Just SE , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 } void $ liftIO $ swapMVar progress (17 / loadSteps) 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 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 1 "standing" SE) 0 0 } ) npcposs void $ liftIO $ swapMVar progress (18 / loadSteps) putMVar future (nws, MainData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ Prelude.map (\a -> if a == Just ImgEmpty 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 () 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 return (pos', stat) 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)] -> (Int, Int) -> ([(V2 Double, AnimState)], [(V2 Double, AnimState)]) 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)] -> 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.!) <$> img) mapM_ drawAnim bef restore ctx where delimiter (V2 nr nc, _) = 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 = nr - fromIntegral ((floor nr) :: Int) :: Double nnc = 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, _) -> sc + sr * fromIntegral col) 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 let direction :: V2 Double -> Direction -> Direction direction vel'@(V2 vr _) rot' = if sqrt (vel' `dot` vel') > 0 then let xuu = acos ((vel' `dot` V2 0 1) / sqrt (vel' `dot` vel')) / pi * 180 xu = if vr < 0 then 360 - xuu else xuu d | xu < 22.5 = NE | xu > 22.5 && xu < 67.5 = E | xu > 67.5 && xu < 112.5 = SE | xu > 112.5 && xu < 157.5 = S | xu > 157.5 && xu < 202.5 = SW | xu > 202.5 && xu < 247.5 = W | xu > 247.5 && xu < 292.5 = NW | xu > 292.5 && xu < 337.5 = N | xu > 337.5 = NE | otherwise = NE in d else rot' (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do emap allEnts $ do with anim with pos 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 = direction vel' rot' } } | otherwise -> stat { asId = aId { aiDirection = direction vel' rot' , aiName = "standing" } , asCurrentFrame = 0 } "standing" | sqrt (vel' `dot` vel') > 0 -> stat { asId = aId { aiDirection = direction vel' rot' , aiName = "walking" } , asCurrentFrame = 0 } | otherwise -> stat { asId = aId { aiDirection = direction vel' rot' } } x -> error ("unknown animation name" ++ x) ent = unchanged { pos = Set npos , rot = Set $ direction vel' rot' , anim = Set nstat } return ent 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 = direction vel' rot' } } | otherwise -> stat { asId = aId { aiDirection = direction vel' rot' , aiName = "standing" } , asCurrentFrame = 0 } "standing" | sqrt (colldpos `dot` colldpos) > 0 -> stat { asId = aId { aiDirection = direction vel' rot' , aiName = "walking" } , asCurrentFrame = 0 } | otherwise -> stat { asId = aId { aiDirection = direction vel' rot' } } 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))) 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 (direction vel' rot') , anim = Set nstat } 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)