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 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 = length (Prelude.filter (\p -> pointType p /= RoomExit) rps) liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show nnex npcposs <- placeNPCs inter mat rps gr nnex (nws, _) <- yieldSystemT (worldState ud) $ do void $ newEntity $ defEntity { pos = Just (V2 20.5 20.5) , vel = Just (V2 0 0) , player = Just () } void $ mapM_ (\(V2 nr nc) -> do -- ttl <- liftIO $ randomRIO (5, 30) newEntity $ defEntity { pos = Just (V2 (nr + 0.5) (nc + 0.5)) , vel = Just (V2 0 0) , npcState = Just (NPCStanding 0) } ) 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, _) <- yieldSystemT (worldState ud) $ do emap $ do with player pure $ defEntity' { 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, _) <- yieldSystemT (worldState ud) $ do emap $ do with player pure $ defEntity' { vel = Set $ V2 0 0 } putAffection ud { worldState = nws } movePlayer _ = return () drawMap :: Affection UserData () drawMap = do ud <- getAffection dt <- getDelta (_, (playerPos, npcposs)) <- yieldSystemT (worldState ud) $ do pc <- efor $ \_ -> do with player with pos pos' <- E.get pos pure pos' -- (_, npcposs) <- yieldSystemT (worldState ud) $ do npcs <- efor $ \_ -> do with npcState with pos pos' <- E.get 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 liftIO $ drawTile (assetImages ud) ctx pr pc i j t drawNPCs ctx 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, _) <- yieldSystemT (worldState ud) $ do emap $ do without player with vel with pos pos'@(V2 pr pc) <- E.get pos vel' <- E.get vel let npos@(V2 nr nc) = pos' + fmap (* dt) vel' dpos = npos - pos' ent = defEntity' { pos = Set $ npos } return ent emap $ do with player with vel with pos pos'@(V2 pr pc) <- E.get pos vel' <- E.get 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 = defEntity' { pos = Set $ pos' + dpos * Prelude.foldl (\acc a -> let ret = checkBoundsCollision2 pos' npos dt acc a in A.log A.Debug (show ret) ret) (V2 1 1) ( concatMap (\(dr, dc) -> let bs = fromMaybe [] (imgObstacle <$> (M.safeGet (fromIntegral $ floor nr + dr) (fromIntegral $ floor nc + 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.Debug (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 < 0 && colltc < 0) || (inrow && incol) = A.log A.Debug ("both " ++ show (colltr, colltc)) (V2 0 0) | colltr < 0 && incol = (A.log A.Debug ("row fixed " ++ show (colltr, colltc))(V2 0 1)) * acc | colltc < 0 && inrow = (A.log A.Debug ("col fixed " ++ show (colltr, colltc))(V2 1 0)) * acc | otherwise = acc where vel@(V2 vr vc) = fmap (/ dt) (next - pre) colltr | vr > 0 = (((fromIntegral (floor nr :: Int)) + minr - 0.15) - nr) / vr | vr < 0 = (((fromIntegral (floor nr :: Int)) + maxr + 0.15) - nr) / vr | otherwise = 0 colltc | vc > 0 = (((fromIntegral (floor nc :: Int)) + minc - 0.15) - nc) / vc | vc < 0 = (((fromIntegral (floor nc :: Int)) + maxc + 0.15) - nc) / vc | otherwise = 0 inrow = pr > minr && pr < maxr incol = pc > minc && pc < maxc