diff --git a/src/Load.hs b/src/Load.hs index 016e24e..310be26 100644 --- a/src/Load.hs +++ b/src/Load.hs @@ -20,7 +20,7 @@ import NanoVG hiding (V2(..)) -- internal imports import Types -import MainGame +import MainGame.WorldMap import Util loadLoad :: Affection UserData () @@ -157,7 +157,7 @@ updateLoad _ = do putAffection ud { assetImages = loadAssetImages ld , assetAnimations = loadAssetAnims ld - , state = Main + , state = Main WorldMap , stateData = None } loadMap diff --git a/src/MainGame/MindMap.hs b/src/MainGame/MindMap.hs new file mode 100644 index 0000000..ed888aa --- /dev/null +++ b/src/MainGame/MindMap.hs @@ -0,0 +1,324 @@ +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 Control.Monad (when) + +import NanoVG hiding (V2(..)) + +import SDL hiding (E(..)) + +import Foreign.C.Types + +-- internal imports + +import Types + +import MainGame.WorldMap (checkBoundsCollision2) + +updateMind :: Double -> Affection UserData () +updateMind dt = do + ud <- getAffection + 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 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 mmrot + with anim + pos'@(V2 pr pc) <- query mmpos + 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) + len = sqrt (dpos `dot` dpos) + 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 = fromMaybe [] (imgObstacle <$> M.safeGet + (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 (direction vel' rot') + , anim = Set nstat + } + return ent + putAffection ud + { worldState = nws + } + +drawMind :: Affection UserData () +drawMind = do + ud <- getAffection + let ctx = nano ud + dt <- getDelta + (_, (playerPos, posanims)) <- liftIO $ 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 + return (pos', stat) + 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 $ 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 coord@(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 + when (isJust img) drawImage + 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) + nnc = nc - fromIntegral (floor nc) + -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs && + -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs + ai = assetImages ud + anims = assetAnimations ud + 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 = imgObstacle img + drawAnim (V2 nr nc, as) = do + let ax = realToFrac $ 640 + ((nc - pc) + (nr - pr)) * 32 + ay = realToFrac $ 360 + ((nr - pr) - (nc - pc)) * 16 + a = anims Map.! asId as + beginPath ctx + paint <- imagePattern ctx (ax - 32) (ay - 58) 64 74 0 + (animSprites a !! asCurrentFrame as) 1 + rect ctx (ax - 32) (ay - 58) 64 74 + fillPaint ctx paint + fill ctx + drawImage = do + beginPath ctx + paint <- imagePattern + ctx x (y - (74 - realToFrac tileHeight)) + (realToFrac tileWidth) 74 + 0 + (ai Map.! fromJust img) + fact + rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74 + fillPaint ctx paint + fill ctx diff --git a/src/MainGame.hs b/src/MainGame/WorldMap.hs similarity index 91% rename from src/MainGame.hs rename to src/MainGame/WorldMap.hs index 51c2c54..97663d3 100644 --- a/src/MainGame.hs +++ b/src/MainGame/WorldMap.hs @@ -1,7 +1,9 @@ -module MainGame where +module MainGame.WorldMap where import Affection as A +import Algebra.Graph as AG + import qualified SDL import NanoVG hiding (V2(..)) @@ -16,7 +18,7 @@ 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) +import Data.List as L (sortOn, partition, find) import System.Random (randomRIO) @@ -30,6 +32,7 @@ import Interior import Util import Types import Floorplan +import MindMap import NPC loadMap :: Affection UserData () @@ -37,24 +40,40 @@ loadMap = do ud <- getAffection let (Subsystems _ m k) = subsystems ud ctx = nano ud - uu <- partSubscribe m movePlayer + 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 = [uu] + , 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 = 16 + let loadSteps = 18 fc = FloorConfig (10, 10) [(5, 5), (5, 45)] @@ -78,15 +97,35 @@ loadMapFork ud future progress = do npcposs <- placeNPCs inter mat rps gr 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 . floor) <$> mmPos + (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph)) + delta = [(0, 0)] ++ + Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)] + mmpos = Prelude.foldl (\acc (dr, dc) -> + let (V2 pmr pmc) = floor <$> pmmpos + seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc) + in if mmimgmat M.! seekpos == Nothing && mmintmat M.! seekpos == 0 + && acc == Nothing + then Just (pmmpos + (fromIntegral <$> V2 dr dc)) + else acc + ) Nothing delta void $ createEntity $ newEntity { pos = Just (V2 10.5 10.5) + , mmpos = mmpos , 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 (15 / loadSteps) + void $ liftIO $ swapMVar progress (17 / loadSteps) void $ mapM_ (\npcpos@(V2 nr nc) -> do fact <- liftIO $ randomRIO (0.5, 1.5) future <- liftIO newEmptyMVar @@ -100,7 +139,7 @@ loadMapFork ud future progress = do , anim = Just $ AnimState (AnimId 1 "standing" SE) 0 0 } ) npcposs - void $ liftIO $ swapMVar progress (16 / loadSteps) + void $ liftIO $ swapMVar progress (18 / loadSteps) putMVar future (nws, MainData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ @@ -108,6 +147,7 @@ loadMapFork ud future progress = do (\a -> if a == Just ImgEmpty then Nothing else a) (M.toList inter) , reachPoints = rps + , mmImgMat = mmimgmat }) mouseToPlayer :: V2 Int32 -> Affection UserData () @@ -338,6 +378,7 @@ updateMap dt = do (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 diff --git a/src/MindMap.hs b/src/MindMap.hs index 9b2b3dc..affde8a 100644 --- a/src/MindMap.hs +++ b/src/MindMap.hs @@ -72,7 +72,7 @@ springField inGraph = in (mmId node, fmap (* friction) accel) calcul graph = let deltas = map (calculDelta graph) (vertexList graph) - in if any (\(_, v) -> len v > 0.05) + in if any (\(_, v) -> len v > 0.1) (A.log A.Debug ("deltas: " ++ show deltas) deltas) -- deltas then @@ -87,14 +87,16 @@ springField inGraph = normv v@(V2 0 0) = v normv v = signorm v -buildFloorMap :: AG.Graph MMNode -> M.Matrix Int +buildFloorMap :: AG.Graph MMNode -> (M.Matrix Int, AG.Graph MMNode) buildFloorMap inGraph = - foldl - (\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i) - (floor r + 2, floor c + 2) amat - ) - emptyFloor - (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph) + ( foldl + (\amat (MMNode (V2 r c) i) -> M.setElem (if i == 0 then -2 else i) + (floor r + 2, floor c + 2) amat + ) + emptyFloor + (A.log A.Debug ("floorGraph: " ++ show floorGraph) floorGraph) + , fmap (\n -> n { mmPos = (+ 2) <$> mmPos n} ) floorGraph + ) where normGraph = let minVert = V2 @@ -109,3 +111,41 @@ buildFloorMap inGraph = fmap (\n -> n { mmPos = (* 45) <$> mmPos n} ) (A.log A.Verbose ("normGraph: " ++ (show $ vertexList normGraph)) normGraph) emptyFloor = M.matrix 50 50 (const 0) + +manhattan :: AG.Graph MMNode -> M.Matrix Int -> M.Matrix TileState +manhattan graph input = + walls intermediate + where + distance :: (Int, Int) -> (Int, Int) -> Int + distance (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2) + dmin = M.nrows input + M.ncols input + calculate (r, c) = foldl (\acc@(accdmin, accind) (MMNode (V2 vr vc) ind) -> + let d = distance (r, c) (floor vr, floor vc) + in if d < accdmin + then (d, ind) + else acc + ) (dmin, 0) vertices + vertices = vertexList graph + coords = (,) <$> [1 .. M.nrows input] <*> [1 .. M.ncols input] + intermediate = M.matrix (M.nrows input) (M.ncols input) (snd . calculate) + walls inter = foldl (\accmat (r, c) -> + let neighbNodes d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) inter) d + neighbWalls d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) accmat) d + cross = [(0, 1), (0, -1), (1, 0), (-1, 0)] + deltas = ((,) <$> [(-1) .. 1] <*> [(-1) .. 1]) + in wallnotwall inter accmat r c + ) emptyMM coords + emptyMM = M.matrix (M.nrows input) (M.ncols input) (const Offi) + wallnotwall inter mat r c + | M.safeGet (r - 1) (c - 1) mat /= Just Wall && + M.safeGet r (c - 1) mat == Just Wall && + M.safeGet (r - 1) c mat == Just Wall = M.setElem Wall (r, c) mat + | (M.safeGet r (c - 1) inter /= M.safeGet r c inter) && + (M.safeGet r (c - 1) mat /= Just Wall) = M.setElem Wall (r, c) mat + | (M.safeGet (r - 1) c inter /= M.safeGet r c inter) && + (M.safeGet (r - 1) c mat /= Just Wall) = M.setElem Wall (r, c) mat + | (M.safeGet r (c + 1) inter /= M.safeGet r c inter) && + (M.safeGet r (c + 1) mat /= Just Wall) = M.setElem Wall (r, c) mat + | (M.safeGet (r + 1) c inter /= M.safeGet r c inter) && + (M.safeGet (r + 1) c mat /= Just Wall) = M.setElem Wall (r, c) mat + | otherwise = mat diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 7595143..85f95a3 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -7,18 +7,21 @@ import Affection import Types import Load -import MainGame +import MainGame.WorldMap +import MainGame.MindMap instance StateMachine State UserData where - smLoad Main = loadMap + smLoad (Main _) = loadMap smLoad Load = loadLoad - smUpdate Main = updateMap + smUpdate (Main WorldMap) = updateMap + smUpdate (Main MindMap) = updateMind smUpdate Load = updateLoad - smDraw Main = drawMap + smDraw (Main WorldMap) = drawMap + smDraw (Main MindMap) = drawMind smDraw Load = drawLoad diff --git a/src/Types/StateData.hs b/src/Types/StateData.hs index 62de40d..5cdf10e 100644 --- a/src/Types/StateData.hs +++ b/src/Types/StateData.hs @@ -22,5 +22,6 @@ data StateData { mapMat :: Matrix TileState , imgMat :: Matrix (Maybe ImgId) , reachPoints :: [ReachPoint] + , mmImgMat :: Matrix (Maybe ImgId) } deriving (Eq) diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 94d8a10..6e325b7 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -44,15 +44,22 @@ data UserData = UserData data State = Load - | Main + | Main SubMain | Test +data SubMain + = WorldMap + | MindMap + data Entity f = Entity { pos :: Component f 'Field (V2 Double) + , mmpos :: Component f 'Field (V2 Double) , gridPos :: Component f 'Field (V2 Int) , vel :: Component f 'Field (V2 Double) + , mmvel :: Component f 'Field (V2 Double) , velFact :: Component f 'Field Double , rot :: Component f 'Field Direction + , mmrot :: Component f 'Field Direction , obstacle :: Component f 'Field (Boundaries Double) , player :: Component f 'Unique () , npcMoveState :: Component f 'Field NPCMoveState diff --git a/tracer-game.cabal b/tracer-game.cabal index ff83de7..2f9400c 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -33,7 +33,8 @@ executable tracer-game , Interior , Init , Load - , MainGame + , MainGame.WorldMap + , MainGame.MindMap , Navigation , MindMap , NPC