From 061d5c3edea72407e98c51ec42bc6ebfaa9a6d35 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 3 Mar 2018 11:06:38 +0100 Subject: [PATCH] no more floortiles --- src/Test.hs | 143 ++++++++++++++++++++++++++-------------------------- src/Util.hs | 16 ++++++ 2 files changed, 87 insertions(+), 72 deletions(-) diff --git a/src/Test.hs b/src/Test.hs index c8a5800..da6f392 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -12,7 +12,7 @@ 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 (toLists, (!), Matrix, safeGet) +import Data.Matrix as M import Data.Ecstasy as E import Data.Maybe (fromJust) @@ -35,7 +35,7 @@ import Util loadMap :: Affection UserData () loadMap = do ud <- getAffection - let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (40,40) + let fc = FloorConfig (20, 20) [(5,5), (35, 35)] (50,75) (Subsystems _ m) = subsystems ud matrix <- liftIO $ buildHallFloorIO fc (nws, _) <- yieldSystemT (worldState ud) $ do @@ -55,17 +55,6 @@ loadMap = do , uuid = [uu] } -relativizeMouseCoords :: V2 Int32 -> IO (V2 Double) -relativizeMouseCoords (V2 ix iy) = do - (GL.Position vx vy, GL.Size vw vh) <- SDL.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) - mouseToPlayer :: V2 Int32 -> Affection UserData () mouseToPlayer mv2 = do ud <- getAffection @@ -104,11 +93,40 @@ drawMap :: Affection UserData () drawMap = do ud <- getAffection dt <- getDelta - let matrix = imgMat (stateData ud) - mapM_ (\(i, ls) -> mapM_ (uncurry $ drawTile i) (reverse $ zip [1..] ls)) - (zip [1..] (toLists matrix)) + (_, playerPos) <- yieldSystemT (worldState ud) $ do + efor $ \_ -> do + with player + pos' <- E.get pos + pure pos' + let V2 pr pc = head playerPos + matrix = imgMat (stateData ud) + ctx = nano ud + cols = fromIntegral (ncols matrix) + rows = fromIntegral (nrows matrix) + 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 - let ctx = nano ud + beginPath ctx + moveTo ctx x y + lineTo ctx + (x + cols * (realToFrac tileWidth / 2)) + (y - realToFrac tileHeight / 2 * cols) + lineTo ctx + (x + realToFrac tileWidth / 2 * (cols + rows)) + (y + (rows - cols) * (realToFrac tileHeight / 2)) + lineTo ctx + (x + realToFrac tileWidth / 2 * rows) + (y + realToFrac tileHeight / 2 * rows) + closePath ctx + fillColor ctx (rgb 255 255 255) + fill ctx + mapM_ (\(i, ls) -> mapM_ + (\(j, t) -> drawTile + ((mapMat $ stateData ud) M.! (i, j)) (assetImages ud) ctx pr pc i j t) + (reverse $ zip [1..] ls)) + (zip [1..] (toLists matrix)) fontSize ctx 20 fontFace ctx (assetFonts ud Map.! FontBedstead) textAlign ctx (S.fromList [AlignCenter,AlignTop]) @@ -146,61 +164,42 @@ updateMap dt = do { worldState = nws } -drawTile :: Int -> Int -> Maybe ImgId -> Affection UserData () -drawTile row col img = do - ud <- getAffection - (_, playerPos) <- yieldSystemT (worldState ud) $ do - efor $ \_ -> do - with player - pos' <- E.get pos - pure pos' - let V2 pr pc = head playerPos - ctx = nano ud - tile = (mapMat $ stateData ud) M.! (row, col) - (xinit, yinit) = initCoords $ stateData ud - tileWidth = 64 :: Double +drawTile :: TileState -> Map ImgId Image -> Context -> Double -> Double -> Int -> Int -> Maybe ImgId -> IO () +drawTile tile ai ctx pr pc row col img = do + let tileWidth = 64 :: Double tileHeight = 32 :: Double - liftIO $ do - save ctx + save ctx + let x = realToFrac $ 640 + ((fromIntegral col - pc) + + (fromIntegral row - pr)) * (tileWidth / 2) + y = realToFrac $ 360 - (tileHeight / 2) + ((fromIntegral row - pr) - + (fromIntegral col - pc)) * (tileHeight / 2) + unless (img == Nothing) $ do + let dist = distance (V2 (fromIntegral row) (fromIntegral col)) + (V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4 + fact = if floor pr <= row && floor pc >= col + then min 1 dist + else 1 + paint <- imagePattern + ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0 + (ai Map.! fromJust img) + fact beginPath ctx - let x = realToFrac $ 640 + ((fromIntegral col - pc) + - (fromIntegral row - pr)) * (tileWidth / 2) - y = realToFrac $ 360 - (tileHeight / 2) + ((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 - Hall -> rgba 255 255 255 255 - Offi -> rgba 0 255 0 255 - Toil -> rgba 0 0 255 255 - Kitc -> rgba 255 0 0 255 - Elev -> rgba 0 0 0 255 - _ -> rgba 255 255 0 255 - ) - moveTo ctx x (y + realToFrac tileHeight / 2) - lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight) - lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2) - lineTo ctx (x + realToFrac tileWidth / 2) y - closePath ctx - fill ctx - unless (img == Nothing) $ do - let dist = distance (V2 (fromIntegral row) (fromIntegral col)) - (V2 (realToFrac pr - 0.5) (realToFrac pc + 0.5)) / 4 - fact = if floor pr <= row && floor pc >= col - then min 1 dist - else 1 - paint <- imagePattern - ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 0 - (assetImages ud Map.! fromJust img) - fact - beginPath ctx - rect ctx x (y - (74 * fact - realToFrac tileHeight)) 64 74 - fillPaint ctx paint - fill ctx - when (floor pr == row && floor pc == col) $ do - beginPath ctx - circle ctx 640 360 5 + if fact < 1 + then do + moveTo ctx x (y + (realToFrac tileHeight - 74 * fact)) + lineTo ctx (x + realToFrac tileWidth) (y + (realToFrac tileHeight - 74 * fact)) + lineTo ctx (x + realToFrac tileWidth) (y + realToFrac tileHeight / 2) + lineTo ctx (x + realToFrac tileWidth / 2) (y + realToFrac tileHeight) + lineTo ctx x (y + realToFrac tileHeight / 2) closePath ctx - fillColor ctx (rgba 0 255 255 255) - fill ctx - restore ctx + else + rect ctx x (y - (74 - realToFrac tileHeight)) (realToFrac tileWidth) 74 + fillPaint ctx paint + fill ctx + 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 + restore ctx diff --git a/src/Util.hs b/src/Util.hs index 0bc7e84..21da383 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -4,6 +4,11 @@ import Affection as A import Data.Matrix as M +import qualified SDL +import qualified Graphics.Rendering.OpenGL as GL hiding (get) + +import Linear + -- internal imports import Types @@ -93,3 +98,14 @@ neighWalls row col mat = , (0, 1) , (1, 0) ] + +relativizeMouseCoords :: V2 Int32 -> IO (V2 Double) +relativizeMouseCoords (V2 ix iy) = do + (GL.Position vx vy, GL.Size vw vh) <- SDL.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)