module Test where import Affection as A hiding (get) import SDL (get, ($=)) import qualified SDL import qualified Graphics.Rendering.OpenGL as GL hiding (get) import NanoVG hiding (V2(..)) import Control.Monad (when, unless, 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 System.Random (randomRIO) import Linear import Foreign.C.Types (CFloat(..)) import Debug.Trace -- internal imports import Interior import Util import Types import Floorplan import NPC loadMap :: Affection UserData () loadMap = do ud <- getAffection let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (50,75) (Subsystems _ m) = subsystems ud (mat, gr) <- liftIO $ buildHallFloorIO fc let imgmat = convertTileToImg mat exits = Prelude.foldl (\acc coord@(r, c) -> if imgmat M.! coord == Just ImgEmpty then ReachPoint RoomExit (V2 r c) : acc else acc ) [] ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) -- liftIO $ A.logIO A.Debug (show exits) (inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps)) let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length nnex) npcposs <- placeNPCs inter mat rps gr (length nnex) (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do void $ createEntity $ newEntity { pos = Just (V2 20.5 20.5) , vel = Just (V2 0 0) , player = Just () } void $ mapM_ (\npcpos@(V2 nr nc) -> do -- ttl <- liftIO $ randomRIO (5, 30) fact <- liftIO $ randomRIO (0.5, 1.5) future <- liftIO $ newEmptyMVar _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter createEntity $ newEntity { pos = Just (V2 (nr + 0.5) (nc + 0.5)) , vel = Just (V2 0 0) , velFact = Just fact , npcState = Just (NPCStanding 0 future) } ) npcposs uu <- partSubscribe m movePlayer putAffection ud { worldState = nws , stateData = 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 } , uuid = [uu] } 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) $ do 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) $ do 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 dt <- getDelta (_, (playerPos, npcposs)) <- liftIO $ yieldSystemT (worldState ud) $ do pc <- efor allEnts $ do with player with pos pos' <- query pos pure pos' -- (_, npcposs) <- yieldSystemT (worldState ud) $ do npcs <- efor allEnts $ do with npcState with pos pos' <- query pos pure pos' return (pc, npcs) let V2 pr pc = head playerPos mat = imgMat (stateData ud) ctx = nano 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) 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) -> do drawTile (assetImages ud) ctx pr pc i j t drawNPCs ctx ud npcposs pr pc i j t ) (reverse $ zip [1..] ls)) (zip [1..] (toLists mat)) -- liftIO $ do -- draw FPS 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))) updateMap :: Double -> Affection UserData () updateMap dt = do ud <- getAffection (nws, _) <- liftIO $ yieldSystemT (worldState ud) $ do emap allEnts $ do without player with vel with velFact with pos pos'@(V2 pr pc) <- query pos vel' <- query vel fact' <- query velFact let npos@(V2 nr nc) = pos' + fmap (* (dt * fact')) vel' dpos = npos - pos' ent = unchanged { pos = Set $ npos } return ent emap allEnts $ do with player with vel with pos pos'@(V2 pr pc) <- query pos vel' <- query vel let npos@(V2 nr nc) = pos' + fmap (* dt) vel' dpos@(V2 dpr dpc) = npos - pos' 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)]) -- lll = Prelude.map (\i -> -- let lrow = -- [ (nr - (fromIntegral $ floor nr)) -- , (nr - (fromIntegral $ floor nr)) + (dpr / len) -- .. -- ] -- lcol = -- [ (nc - (fromIntegral $ floor nc)) -- , (nc - (fromIntegral $ floor nc)) + (dpc / len) -- .. -- ] -- in (fromIntegral (floor (lrow !! i)), fromIntegral (floor (lcol !! i))) -- ) -- [ 0 .. floor len] ent = unchanged { pos = Set $ pos' + 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 ) (A.log A.Verbose (show lll ++ " " ++ show len) lll) ) } return ent updateNPCs (imgMat $ stateData ud) (Prelude.filter (\p -> pointType p /= RoomExit) (reachPoints $ stateData ud) ) dt putAffection ud { worldState = nws } drawTile :: Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO () drawTile ai ctx pr pc row col img = when ((realToFrac x > -tileWidth && realToFrac y > -tileHeight) && (realToFrac x < 1280 && realToFrac (y - (74 - realToFrac tileHeight)) < 720)) $ do save ctx if (isNothing img) then drawPlayer else do if (Prelude.null mb) then do drawImage drawPlayer else do if (all (\m -> pr > (fromIntegral (floor pr :: Int)) + m) minrs && all (\m -> pc < (fromIntegral (floor pc :: Int)) + m) mincs) || (all (\m -> pr > (fromIntegral (floor pr :: Int)) + m) minrs && all (\m -> pc < (fromIntegral (floor pc :: Int)) + m) maxcs) then do drawImage drawPlayer else do drawPlayer drawImage restore ctx where tileWidth = 64 :: Double tileHeight = 32 :: Double 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 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 drawPlayer = do when (floor pr == row && floor pc == col) $ do beginPath ctx circle ctx 640 360 5 closePath ctx fillColor ctx (rgba 0 255 255 255) fill ctx checkBoundsCollision :: V2 Double -> V2 Double -> V2 Double -> Boundaries Double -> V2 Double checkBoundsCollision (V2 pr pc) (V2 fr fc) (V2 mr mc) (Boundaries (minr, minc) (maxr, maxc)) | ntestc && ntestr && not testr && not testc = V2 (1 * mr) (1 * mc) | ntestc && ntestr && not testc = V2 (1 * mr) (0 * mc) | ntestr && ntestc && not testr = V2 (0 * mr) (1 * mc) | not ntestr && not ntestc = V2 (1 * mr) (1 * mc) | not ntestr && ntestc = V2 (1 * mr) (1 * mc) | not ntestc && ntestr = V2 (1 * mr) (1 * mc) | otherwise = V2 (0 * mr) (0 * mc) where ntestr = ndistr <= hheight + 0.15 -- | ncdistsq <= 0.005 = True ntestc = ndistc <= hwidth + 0.15 -- | ncdistsq <= 0.005 = True testr = distr <= hheight + 0.15 -- | cdistsq <= 0.005 = True testc = distc <= hwidth + 0.15 -- | cdistsq <= 0.005 = True ndistr = abs (fr - (fromIntegral (floor fr :: Int) + (minr + hheight))) ndistc = abs (fc - (fromIntegral (floor fc :: Int) + (minc + hwidth))) distr = abs (pr - (fromIntegral (floor fr :: Int) + (minr + hheight))) distc = abs (pc - (fromIntegral (floor fc :: Int) + (minc + hwidth))) hheight = (maxr - minr) / 2 hwidth = (maxc - minc) / 2 ncdistsq = (ndistr - hheight) ^ (2 :: Int) + (ndistc - hwidth) ^ (2 :: Int) cdistsq = (distr - hheight) ^ (2 :: Int) + (distc - hwidth) ^ (2 :: Int) checkBoundsCollision2 :: V2 Double -> V2 Double -> Double -> V2 Double -> Boundaries Double -> V2 Double checkBoundsCollision2 pre@(V2 pr pc) next@(V2 nr nc) 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 vel@(V2 vr vc) = fmap (/ dt) (next - 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) prc = pc - (fromIntegral $ floor pc)