module Test where import Affection as A 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) import System.Random (randomRIO) import Linear hiding (E) import Foreign.C.Types (CFloat(..)) -- internal imports import Interior import Util import Types import Floorplan import NPC loadMap :: Affection UserData () loadMap = do ud <- getAffection let (Subsystems _ m) = subsystems ud ctx = nano ud uu <- partSubscribe m movePlayer future <- liftIO $ newEmptyMVar progress <- liftIO $ newMVar 0 _ <- liftIO $ forkIO $ loadMapFork ud future progress putAffection ud { stateData = None , uuid = [uu] , stateMVar = future , stateProgress = progress } loadMapFork :: UserData -> MVar (SystemState Entity IO, StateData) -> MVar Float -> IO () loadMapFork ud future progress = do let loadSteps = 16 fc = FloorConfig (10, 10) [] (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 gr 50 -- (length nnex) _ <- liftIO $ swapMVar progress (14 / loadSteps) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) (nws, _) <- yieldSystemT (worldState ud) $ do void $ createEntity $ newEntity { pos = Just (V2 10.5 10.5) , vel = Just (V2 0 0) , player = Just () , rot = Just SE , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 } void $ liftIO $ swapMVar progress (15 / loadSteps) void $ mapM_ (\npcpos@(V2 nr nc) -> do fact <- liftIO $ randomRIO (0.5, 1.5) future <- liftIO newEmptyMVar _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future 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 , npcState = Just (NPCStanding 0 future) , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 } ) npcposs void $ liftIO $ swapMVar progress (16 / loadSteps) putMVar future (nws, MenuData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ Prelude.map (\a -> if a == Just ImgEmpty then Nothing else a) (M.toList inter) , initCoords = (0, 500) , reachPoints = rps }) 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 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 (lt, ge) = L.partition delimiter sorted save ctx mapM_ drawAnim lt when (isJust img) drawImage mapM_ drawAnim ge restore ctx where delimiter (V2 nr 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 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 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) 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) (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)