no more floortiles
This commit is contained in:
nek0
parent
bd54ab1474
commit
061d5c3ede
2 changed files with 87 additions and 72 deletions
143
src/Test.hs
143
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
|
||||
|
|
|
|||
16
src/Util.hs
16
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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue