it runs again, but correctness is questionable
This commit is contained in:
parent
8b5a9e6006
commit
23483de264
4 changed files with 74 additions and 32 deletions
|
|
@ -1,9 +1,12 @@
|
|||
module Floorplan where
|
||||
|
||||
import Affection as A
|
||||
|
||||
import Data.Matrix (Matrix(..))
|
||||
import qualified Data.Matrix as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe
|
||||
import Data.List (intersect)
|
||||
|
||||
import Linear (V2(..))
|
||||
|
||||
|
|
@ -69,12 +72,14 @@ buildHallFloorIO fc progress increment = do
|
|||
( p + increment
|
||||
, "Built facilities"
|
||||
)))
|
||||
-- accessGraph <- assignClearance doorgraph facils
|
||||
accessGraph <- assignClearance doorgraph facils
|
||||
modifyMVar_ progress (return . (\(p, _) ->
|
||||
( p + increment
|
||||
, "Assigned room clearances"
|
||||
)))
|
||||
return (facils, doorgraph)
|
||||
A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
|
||||
A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
|
||||
return (facils, accessGraph)
|
||||
|
||||
emptyFloor :: FloorConfig -> Matrix TileState
|
||||
emptyFloor fc =
|
||||
|
|
@ -415,21 +420,42 @@ buildDoorsGraph mat =
|
|||
|
||||
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
|
||||
assignClearance graph imat =
|
||||
mapM doAssignClearance graph
|
||||
foldM doAssignClearance [] graph
|
||||
where
|
||||
doAssignClearance (GHall conns) =
|
||||
GHall <$> mapM (reassign True) conns
|
||||
doAssignClearance room =
|
||||
reassign False room
|
||||
reassign p room@(GRoom ns b c t) =
|
||||
doAssignClearance acc (GHall conns) = do
|
||||
ret <- GHall <$> foldM (\acc a -> do
|
||||
res <- reassign True acc a
|
||||
return (acc ++ [res])
|
||||
) [] conns
|
||||
return (ret : acc)
|
||||
doAssignClearance acc room = do
|
||||
ret <- reassign False acc room
|
||||
return (acc ++ [ret])
|
||||
reassign :: Bool -> [Graph] -> Graph -> IO Graph
|
||||
reassign p acc room@(GRoom ns b c t) =
|
||||
if p
|
||||
then do
|
||||
if actualRoomType b imat == Offi
|
||||
then doRandomAssign room
|
||||
then do
|
||||
ret <- doRandomAssign room
|
||||
return ret
|
||||
else return room
|
||||
else do
|
||||
let neigh = findNeighbor (head ns) b imat graph
|
||||
|
||||
if actualRoomType b imat == Offi
|
||||
then do
|
||||
let neigh =
|
||||
catMaybes
|
||||
(map
|
||||
(\n -> findNeighbor n b imat onlyrooms)
|
||||
nonhalls
|
||||
)
|
||||
onlyrooms = connects (head acc) ++ tail acc
|
||||
nonhalls = ns -- filter ((/= Hall) . snd) ns
|
||||
ret <- if null neigh
|
||||
then doRandomAssign room
|
||||
else doBoundedAssign room (clearance $ head neigh)
|
||||
return ret
|
||||
else return room
|
||||
|
||||
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
|
||||
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
|
||||
|
|
@ -441,7 +467,7 @@ doRandomAssign :: Graph -> IO Graph
|
|||
doRandomAssign g = do
|
||||
c <- randomRIO (0, 4)
|
||||
return g
|
||||
{ clearance = if actualRoomType c
|
||||
{ clearance = c
|
||||
}
|
||||
|
||||
doBoundedAssign :: Graph -> Word -> IO Graph
|
||||
|
|
@ -454,30 +480,35 @@ doBoundedAssign g b = do
|
|||
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
|
||||
findNeighbor (dir, _) bnds imat ingraph
|
||||
| dir == North =
|
||||
let row = fst (matmin bnds) - 2
|
||||
col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2)
|
||||
let row = fst (matmin bnds) - 1
|
||||
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
|
||||
in postprocess row col
|
||||
| dir == East =
|
||||
let row = fst (matmin bnds) + (fst (matmax bnds) - fst (matmin bnds) `div` 2)
|
||||
col = snd (matmin bnds) - 2
|
||||
let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
|
||||
col = snd (matmax bnds) + 1
|
||||
in postprocess row col
|
||||
| dir == South =
|
||||
let row = fst (matmax bnds) + 2
|
||||
col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2)
|
||||
let row = fst (matmax bnds) + 1
|
||||
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
|
||||
in postprocess row col
|
||||
| dir == West =
|
||||
let row = fst (matmin bnds) + (fst (matmax bnds) - fst (matmin bnds) `div` 2)
|
||||
col = snd (matmax bnds) + 2
|
||||
let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
|
||||
col = snd (matmin bnds) - 1
|
||||
in postprocess row col
|
||||
where
|
||||
neighTile row col = imat M.! (row, col)
|
||||
postprocess row col =
|
||||
case filter (inBounds (V2 row col) . bounds) (filter graphIsRoom ingraph) of
|
||||
[a@(GRoom _ _ _ ts)] -> if ts == neighTile row col
|
||||
then Just a
|
||||
else error "findNeighbor: Query Result dies not match"
|
||||
[] -> Nothing
|
||||
_ -> error "findNeighbor: Non-singleton filter result"
|
||||
let filtered = filter
|
||||
(inBounds (V2 row col) . bounds)
|
||||
ingraph
|
||||
in
|
||||
case A.log A.Debug ("filtered: " ++ show filtered) filtered of
|
||||
[a@(GRoom _ _ _ ts)] -> Just a
|
||||
-- if ts == neighTile row col
|
||||
-- then Just a
|
||||
-- else error "findNeighbor: Query Result does not match"
|
||||
[] -> Nothing
|
||||
_ -> error "findNeighbor: Non-singleton filter result"
|
||||
|
||||
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
|
||||
buildDoors = foldM placeDoors
|
||||
|
|
|
|||
|
|
@ -221,7 +221,7 @@ loadMapFork ud ad future progress = do
|
|||
( p + increment
|
||||
, "Registering NPCs into WorldState"
|
||||
)))
|
||||
mapM_ (\crp -> do
|
||||
mapM_ (\cpr -> do
|
||||
fact <- liftIO $ randomRIO (0.5, 1.5)
|
||||
-- fut <- liftIO newEmptyMVar
|
||||
stats <- liftIO $ NPCStats
|
||||
|
|
@ -231,15 +231,21 @@ loadMapFork ud ad future progress = do
|
|||
<*> (randomRIO (0, 1))
|
||||
<*> (randomRIO (0, 1))
|
||||
<*> (randomRIO (0, 1))
|
||||
let room = head
|
||||
(Prelude.filter
|
||||
((inBounds $ pointCoord cpr) . bounds)
|
||||
(Types.connects (head gr) ++ tail gr)
|
||||
)
|
||||
void $ createEntity $ newEntity
|
||||
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord crp))
|
||||
{ pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
|
||||
, vel = Just (V2 0 0)
|
||||
, velFact = Just fact
|
||||
, rot = Just SE
|
||||
, npcMoveState = Just (NPCWalking [pointCoord crp])
|
||||
, npcWorkplace = Just crp
|
||||
, npcMoveState = Just (NPCWalking [pointCoord cpr])
|
||||
, npcWorkplace = Just cpr
|
||||
, npcActionState = Just ASWork
|
||||
, npcStats = Just stats
|
||||
, npcClearanceLvl = Just (clearance room)
|
||||
, anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0
|
||||
}
|
||||
) computers
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ data Entity f = Entity
|
|||
, npcWorkplace :: Component f 'Field ReachPoint
|
||||
, npcActionState :: Component f 'Field NPCActionState
|
||||
, npcStats :: Component f 'Field NPCStats
|
||||
, npcClearanceLvl :: Component f 'Field Int
|
||||
, npcClearanceLvl :: Component f 'Field Word
|
||||
, anim :: Component f 'Field AnimState
|
||||
, objAccess :: Component f 'Field ((V2 Int), Direction)
|
||||
, objType :: Component f 'Field ObjType
|
||||
|
|
|
|||
|
|
@ -58,7 +58,12 @@ data Graph
|
|||
, clearance :: Word
|
||||
, roomType :: TileState
|
||||
}
|
||||
deriving (Show, Eq)
|
||||
deriving (Show)
|
||||
|
||||
instance Eq Graph where
|
||||
(GHall la) == (GHall lb) = la == lb
|
||||
(GRoom na ba _ _) == (GRoom nb bb _ _) = na == nb && ba == bb
|
||||
_ == _ = False
|
||||
|
||||
graphIsRoom :: Graph -> Bool
|
||||
graphIsRoom (GRoom _ _ _ _) = True
|
||||
|
|
|
|||
Loading…
Reference in a new issue