adding simple mouse coordination
This commit is contained in:
nek0
parent
53321a2576
commit
3c3a152265
4 changed files with 104 additions and 77 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
81
src/Test.hs
81
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue