it runs again, but correctness is questionable

This commit is contained in:
nek0 2019-02-08 06:36:52 +01:00
parent 8b5a9e6006
commit 23483de264
4 changed files with 74 additions and 32 deletions

View file

@ -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,28 +480,33 @@ 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"
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"

View file

@ -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

View file

@ -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

View file

@ -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