diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 96005b5..df7777a 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -2,7 +2,6 @@ module Floorplan where import Data.Matrix (Matrix(..)) import qualified Data.Matrix as M -import qualified Data.Vector as V import Data.Maybe import Control.Monad (foldM) @@ -25,7 +24,7 @@ buildHallFloorIO fc = do traceIO "built graph" doors <- buildDoors closed doorgraph traceIO "built doors" - let (g4, facils) = buildFacilities g2 fc doors + let (_, facils) = buildFacilities g2 fc doors return facils emptyFloor :: FloorConfig -> Matrix TileState @@ -57,7 +56,7 @@ placeHalls rng fc input = [(Boundaries (1,1) (nrows input, ncols input))] (elevator fc) 5 input where - doHalls rand bounds cross wmax mat = + doHalls rand bs cross wmax mat = foldl (\(agen, amat) b -> let (row, g1) = randomR (fst (matmin b), fst (matmax b)) agen (col, g2) = randomR (snd (matmin b), snd (matmax b)) g1 @@ -67,7 +66,7 @@ placeHalls rng fc input = if hallRatio nmat < 0.2 && wmax - 1 > 2 then doHalls g3 nbs (row, col) (wmax -1) nmat else (g3, nmat) - ) (rand, mat) bounds + ) (rand, mat) bs boundSize :: Boundaries -> Int boundSize (Boundaries mi ma) = @@ -79,25 +78,25 @@ buildHall -> Boundaries -> Matrix TileState -> ([Boundaries], Matrix TileState) -buildHall coord@(row, col) width bounds mat = +buildHall coord@(row, col) width bs mat = let vertHalls = foldl (\acc c -> M.mapCol - (\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds) + (\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs) then replaceTile cur Hall else cur ) c acc) mat [col - (width `div` 2) .. col + (width `div` 2)] horzHalls = foldl (\acc r -> M.mapRow - (\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds) + (\c cur -> if c >= snd (matmin bs) && c <= snd (matmax bs) then replaceTile cur Hall else cur ) r acc) vertHalls [row - (width `div` 2) .. row + (width `div` 2)] - in ( [ Boundaries (matmin bounds) coord - , Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds)) - , Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col) - , Boundaries coord (matmax bounds) + in ( [ Boundaries (matmin bs) coord + , Boundaries (fst (matmin bs), col) (row, snd (matmax bs)) + , Boundaries (row, snd (matmin bs)) (fst (matmax bs), col) + , Boundaries coord (matmax bs) ] , horzHalls ) @@ -166,8 +165,8 @@ buildInnerWalls rng input = -> Matrix TileState -> (StdGen, Matrix TileState) doCross gen cd@(xr, xc) b imat = - let nbs = map (\(mi, ma) -> Boundaries mi ma) bounds - bounds = + let nbs = map (\(mi, ma) -> Boundaries mi ma) bs + bs = [ (matmin b, cd) , ((fst (matmin b), col), (row, snd (matmax b))) , ((row, snd (matmin b)), (fst (matmax b), col)) @@ -178,7 +177,7 @@ buildInnerWalls rng input = let (fc, gg1) = randomR (fst minb, fst maxb) agen (fr, gg2) = randomR (snd minb, snd maxb) gg1 in (gg2, acc ++ [(fc, fr)]) - ) (gen, []) bounds + ) (gen, []) bs horz = M.mapRow (\icol cur -> if icol >= snd (matmin b) && icol <= snd (matmax b) then replaceTile cur Wall @@ -283,24 +282,9 @@ findNearestOffice mat (rrr, ccc) = buildDoorsGraph :: Matrix TileState -> [Graph] buildDoorsGraph mat = - let maxRow r c - | M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c - | otherwise = r - maxCol r c + let maxCol r c | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1) | otherwise = c - minRow r c - | M.safeGet (r + 1) c mat == Just Offi = minRow (r + 1) c - | otherwise = r - minCol r c - | M.safeGet r (c + 1) mat == Just Offi = minCol r (c + 1) - | otherwise = c - matcoord = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1] - inbounds (qr, qc) fg - | fg == Hall = - Nothing - | otherwise = - Just fg buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph] buildGraph amat root coord@(br, bc) | bc > ncols amat - 1 = @@ -308,7 +292,7 @@ buildDoorsGraph mat = | br > nrows amat - 1 = root | M.safeGet br bc amat == Just Offi = - let flood acc fcoord@(fr, fc) = + let flood acc (fr, fc) = let ncoords = [] ++ (if (fr + 1, fc) `notElem` acc && M.safeGet (fr + 1) fc amat == Just Offi @@ -331,7 +315,7 @@ buildDoorsGraph mat = b = Boundaries (minimum (map fst roomcoords), minimum (map snd roomcoords)) (maximum (map fst roomcoords), maximum (map snd roomcoords)) - neighs = map (\(a, b) -> (a, fromJust b)) (filter ((/=Nothing) . snd) + neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd) [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat) , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat) , (East, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat) @@ -366,7 +350,7 @@ buildDoors input graph = do placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) placeDoors amat (GHall conns) = foldM placeDoors amat conns - placeDoors amat (GRoom neighs bounds) = + placeDoors amat (GRoom neighs bs) = if Hall `elem` map snd neighs then do traceIO "door in Hall" @@ -377,23 +361,23 @@ buildDoors input graph = do North -> inRow amat - (fst (matmin bounds) - 1) - (snd (matmin bounds), snd (matmax bounds)) + (fst (matmin bs) - 1) + (snd (matmin bs), snd (matmax bs)) South -> inRow amat - (fst (matmax bounds) + 1) - (snd (matmin bounds), snd (matmax bounds)) + (fst (matmax bs) + 1) + (snd (matmin bs), snd (matmax bs)) East -> inCol amat - (fst (matmin bounds), fst (matmax bounds)) - (snd (matmin bounds) - 1) + (fst (matmin bs), fst (matmax bs)) + (snd (matmin bs) - 1) West -> inCol amat - (fst (matmin bounds), fst (matmax bounds)) - (snd (matmax bounds) + 1) + (fst (matmin bs), fst (matmax bs)) + (snd (matmax bs) + 1) else do traceIO "door in Office" idx <- randomRIO (0, length neighs - 1) @@ -402,23 +386,23 @@ buildDoors input graph = do North -> inRow amat - (fst (matmin bounds) - 1) - (snd (matmin bounds), snd (matmax bounds)) + (fst (matmin bs) - 1) + (snd (matmin bs), snd (matmax bs)) South -> inRow amat - (fst (matmax bounds) + 1) - (snd (matmin bounds), snd (matmax bounds)) + (fst (matmax bs) + 1) + (snd (matmin bs), snd (matmax bs)) East -> inCol amat - (fst (matmin bounds), fst (matmax bounds)) - (snd (matmin bounds) - 1) + (fst (matmin bs), fst (matmax bs)) + (snd (matmin bs) - 1) West -> inCol amat - (fst (matmin bounds), fst (matmax bounds)) - (snd (matmax bounds) + 1) + (fst (matmin bs), fst (matmax bs)) + (snd (matmax bs) + 1) inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState) inRow mat row cols = do col <- randomRIO cols diff --git a/src/Main.hs b/src/Main.hs index 49e10e7..b34da26 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -41,7 +41,7 @@ pre :: Affection UserData () pre = do Subsystems w m <- subsystems <$> getAffection _ <- partSubscribe w (fitViewport (1280/720)) - _ <- partSubscribe w (exitOnWindowClose) + _ <- partSubscribe w exitOnWindowClose return () update :: Double -> Affection UserData () diff --git a/src/Test.hs b/src/Test.hs index 51cffc9..3f7066f 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -1,52 +1,93 @@ module Test where -import Affection as A +import Affection as A hiding (get) +import SDL (get, ($=)) +import qualified SDL +import qualified Graphics.Rendering.OpenGL as GL hiding (get) + +import Control.Monad (when) import Control.Monad.IO.Class (liftIO) import Data.Matrix (toLists) -import NanoVG +import NanoVG hiding (V2(..)) import Types import Floorplan +import Linear + import Foreign.C.Types (CFloat(..)) +import Debug.Trace loadMap :: Affection UserData () loadMap = do ud <- getAffection - let fc = FloorConfig (10, 10) [] (50,50) + let fc = FloorConfig (20, 20) [(5,5), (45, 95)] (50,100) + (Subsystems _ m) = subsystems ud matrix <- liftIO $ buildHallFloorIO fc + uu <- partSubscribe m movePlayer putAffection ud { stateData = MenuData { mapMat = matrix - , initCoords = (50, 250) + , initCoords = (0, 500) + , playerCoords = (20, 20) + } + , uuid = [uu] + } + +relativizeMouseCoords :: V2 Int32 -> IO (V2 Double) +relativizeMouseCoords (V2 ix iy) = do + (GL.Position vx vy, GL.Size vw vh) <- get GL.viewport + let rx = ix - vx + ry = iy - vy + hx = fromIntegral vw / 2 + hy = fromIntegral vh / 2 + dx = fromIntegral rx - hx + dy = fromIntegral ry - hy + return $ V2 (dx / hx) (dy / hy) + +movePlayer :: MouseMessage -> Affection UserData () +movePlayer (MsgMouseMotion _ _ _ [SDL.ButtonLeft] mv2@(V2 mx my) _) = do + ud <- getAffection + rela@(V2 rx ry) <- liftIO $ relativizeMouseCoords mv2 + let dr = (- ry) + (- rx) + dc = (- rx) - (- ry) / 2 + (pr, pc) = playerCoords $ stateData ud + liftIO $ traceIO $ "delta: " ++ show (V2 rx ry) + liftIO $ traceIO $ "movement: " ++ show (V2 dr dc) + putAffection ud + { stateData = (stateData ud) + { playerCoords = (pr - dr, pc - dc) } } +movePlayer _ = return () drawMap :: Affection UserData () drawMap = do ud <- getAffection let matrix = mapMat (stateData ud) - mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls)) - (zip [1..] (toLists matrix)) + mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [0..] ls)) + (zip [0..] (toLists matrix)) drawTile :: Int -> Int -> TileState -> Affection UserData () drawTile row col tile = do - ctx <- nano <$> getAffection - (xinit, yinit) <- initCoords <$> stateData <$> getAffection - let tileWidth = 20 :: CFloat - tileHeight = 10 :: CFloat + ud <- getAffection + let ctx = nano ud + (xinit, yinit) = initCoords $ stateData ud + (pr, pc) = playerCoords $ stateData ud + tileWidth = 20 :: Double + tileHeight = 10 :: Double liftIO $ do save ctx beginPath ctx - let x = fromIntegral xinit + (fromIntegral col * tileWidth / 2) + - (fromIntegral row * tileWidth / 2) - y = fromIntegral yinit + (fromIntegral row * tileHeight / 2) - - (fromIntegral col * tileHeight / 2) + let x = realToFrac $ 650 + ((fromIntegral col - pc) + + (fromIntegral row - pr)) * (tileWidth / 2) + y = realToFrac $ 360 + ((fromIntegral row - pr) - + (fromIntegral col - pc)) * (tileHeight / 2) fillColor ctx (case tile of Wall -> rgba 128 128 128 255 Door -> rgba 255 128 128 255 @@ -58,9 +99,15 @@ drawTile row col tile = do _ -> rgba 255 255 0 255 ) moveTo ctx x y - lineTo ctx (x + tileWidth / 2) (y + tileHeight / 2) - lineTo ctx (x + tileWidth) y - lineTo ctx (x + tileWidth / 2) (y - tileHeight / 2) + lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight / 2) + lineTo ctx (x + realToFrac tileWidth) y + lineTo ctx (x + realToFrac tileWidth / 2) (y - realToFrac tileHeight / 2) closePath ctx fill ctx + when (floor pr + 1 == row && floor pc + 1 == col) $ do + beginPath ctx + circle ctx 640 360 5 + closePath ctx + fillColor ctx (rgba 0 255 255 255) + fill ctx restore ctx diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index d03a3ef..ad1d77b 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -5,19 +5,14 @@ module Types.UserData where import Affection -import qualified SDL - import Control.Concurrent.STM import NanoVG hiding (V2(..), V3(..)) import qualified Data.Map.Strict as M -import Data.Text (Text(..)) import Data.Matrix import Data.Ecstasy -import Linear - import Types.Map data UserData = UserData @@ -39,6 +34,7 @@ data StateData | MenuData { mapMat :: Matrix TileState , initCoords :: (Int, Int) + , playerCoords :: (Double, Double) } data ImgId @@ -106,15 +102,15 @@ generalSubscribe -> (msg -> Affection UserData ()) -> Affection UserData UUID generalSubscribe t funct = do - uuid <- genUUID - liftIO $ atomically $ modifyTVar' t ((uuid, funct) :) - return uuid + uu <- genUUID + liftIO $ atomically $ modifyTVar' t ((uu, funct) :) + return uu generalUnSubscribe :: TVar [(UUID, msg -> Affection UserData ())] -> UUID -> Affection UserData () -generalUnSubscribe t uuid = - liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid)) +generalUnSubscribe t uu = + liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu)) where filterMsg (u, _) p = u /= p