nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

linting in progress

Browse source
This commit is contained in:
nek0 2018-09-02 10:44:33 +02:00
parent 8d2aba5f7b
commit 5916f302a6
9 changed files with 50 additions and 50 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
src/Floorplan.hs
View file

@ -263,7 +263,7 @@ closeOffices input =
let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1] let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
isNeighbor (row, col) = isNeighbor (row, col) =
let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input
in Hall `elem` (M.toList subm) in Hall `elem` M.toList subm
in foldl (\acc coord -> in foldl (\acc coord ->
if input M.! coord == Offi && isNeighbor coord if input M.! coord == Offi && isNeighbor coord
then M.setElem Wall coord acc then M.setElem Wall coord acc
@ -393,8 +393,7 @@ buildDoorsGraph mat =
in buildGraph mat [GHall []] (2, 2) in buildGraph mat [GHall []] (2, 2)
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState) buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors input graph = buildDoors = foldM placeDoors
foldM placeDoors input graph
where where
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) = placeDoors amat (GHall conns) =

7
src/Interior.hs
View file

@ -40,12 +40,11 @@ placeInteriorIO imat imgmat irp graph =
foldl traverseGraph acc sub foldl traverseGraph acc sub
traverseGraph putt (GRoom _ bnds) = traverseGraph putt (GRoom _ bnds) =
let applicable = let applicable =
(L.sortBy (\b a -> size a `compare` size b) ( L.sortBy (\b a -> size a `compare` size b) (
L.filter L.filter
(\a -> roomType `elem` clusterRoom a && size a <= size bnds) (\a -> roomType `elem` clusterRoom a && size a <= size bnds)
[minBound .. maxBound] :: [Cluster]) [minBound .. maxBound] :: [Cluster])
) roomType = fst (L.minimumBy
roomType = fst (head $ L.sortBy
(\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl (\b a -> (snd a :: Int) `compare` (snd b :: Int)) $ Map.toList $ foldl
(\acc a -> if a `Map.member` acc (\acc a -> if a `Map.member` acc
then Map.insert a (acc Map.! a + 1) acc then Map.insert a (acc Map.! a + 1) acc
@ -75,7 +74,7 @@ placeInteriorIO imat imgmat irp graph =
let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng let (pr, g1) = randomR (fst (matmin bnds) - 1, fst (matmax bnds) - 1) rng
(pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1 (pc, g2) = randomR (snd (matmin bnds) - 1, snd (matmax bnds) - 1) g1
freeRoom = foldl freeRoom = foldl
(\acc a -> if a == Nothing then acc + 1 else acc) (\acc a -> if isNothing a then acc + 1 else acc)
0 0
(M.toList $ M.submatrix (M.toList $ M.submatrix
(fst $ matmin bnds) (fst $ matmax bnds) (fst $ matmin bnds) (fst $ matmax bnds)

2
src/Load.hs
View file

@ -29,7 +29,7 @@ loadLoad = do
ad <- A.get ad <- A.get
ud <- getAffection ud <- getAffection
progress <- liftIO $ newMVar (0, "Starting up") progress <- liftIO $ newMVar (0, "Starting up")
future <- liftIO $ newEmptyMVar future <- liftIO newEmptyMVar
_ <- liftIO $ createFont (nano ud) "bedstead" _ <- liftIO $ createFont (nano ud) "bedstead"
(FileName "assets/font/Bedstead-Semicondensed.ttf") (FileName "assets/font/Bedstead-Semicondensed.ttf")
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $

10
src/MainGame/WorldMap.hs
View file

@ -105,7 +105,7 @@ loadMapFork ud ad future progress = do
npcposs <- placeNPCs inter mat rps 40 -- (length $ filter (\a -> pointType a == Table) nnex) npcposs <- placeNPCs inter mat rps 40 -- (length $ filter (\a -> pointType a == Table) nnex)
_ <- liftIO $ swapMVar progress (14 / loadSteps, "Preparing MindMap graph") _ <- liftIO $ swapMVar progress (14 / loadSteps, "Preparing MindMap graph")
A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
!(mmintmat, mmgraph) <- buildFloorMap . springField <$> (mmintmat, mmgraph) <- buildFloorMap . springField <$>
buildMindMap (length npcposs) 2 buildMindMap (length npcposs) 2
_ <- liftIO $ swapMVar progress (15 / loadSteps, "Unfolding and Converting MindMap to images") _ <- liftIO $ swapMVar progress (15 / loadSteps, "Unfolding and Converting MindMap to images")
let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat let !mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
@ -140,7 +140,7 @@ loadMapFork ud ad future progress = do
{ pos = Just $ reachCoord - V2 1 0 { pos = Just $ reachCoord - V2 1 0
, obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36) , obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
, anim = Just $ AnimState (AnimId "copier" "open" N) 0 0 , anim = Just $ AnimState (AnimId "copier" "open" N) 0 0
, objAccess = Just $ (V2 1 0, NW) , objAccess = Just (V2 1 0, NW)
, objType = Just ObjCopier , objType = Just ObjCopier
, objState = Just "idle" , objState = Just "idle"
} }
@ -155,7 +155,7 @@ loadMapFork ud ad future progress = do
_ -> error "not yet defined" _ -> error "not yet defined"
-- , obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36) -- , obstacle = Just $ Boundaries (10/36, 8/36) (28/36, 30/36)
, anim = Just $ AnimState (AnimId "computer" "off" N) 0 0 , anim = Just $ AnimState (AnimId "computer" "off" N) 0 0
, objAccess = Just $ (V2 1 (-1), dir) , objAccess = Just (V2 1 (-1), dir)
, objType = Just ObjComputer , objType = Just ObjComputer
, objState = Just "off" , objState = Just "off"
} }
@ -168,7 +168,7 @@ loadMapFork ud ad future progress = do
{ pos = Just $ reachCoord - V2 0 (-1) { pos = Just $ reachCoord - V2 0 (-1)
, obstacle = Just $ Boundaries (0, 0) (1, 1) , obstacle = Just $ Boundaries (0, 0) (1, 1)
, anim = Just $ AnimState (AnimId "toilet" "free" N) 0 0 , anim = Just $ AnimState (AnimId "toilet" "free" N) 0 0
, objAccess = Just $ (V2 0 (-1), dir) , objAccess = Just (V2 0 (-1), dir)
, objType = Just ObjToilet , objType = Just ObjToilet
} }
) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets) ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets)
@ -272,7 +272,7 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
otype <- query objType otype <- query objType
ostate <- query objState ostate <- query objState
ent <- queryEnt ent <- queryEnt
if (fmap floor ppos == fmap floor pos' || if ((fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) ||
(fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) && (fmap floor ppos :: V2 Int) == (fmap floor pos' :: V2 Int) + rel) &&
(fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) && (fmap floor (ppos + V2 dr dc) :: V2 Int) == (fmap floor pos' ::V2 Int) &&
pdir == dir pdir == dir

10
src/MindMap.hs
View file

@ -34,7 +34,7 @@ buildMindMap num difficulty = do
aux <- randomRIO (0, floor (fromIntegral num * 5 / 8 :: Double)) :: IO Int aux <- randomRIO (0, floor (fromIntegral num * 5 / 8 :: Double)) :: IO Int
auxPaths <- mapM (\_ -> do auxPaths <- mapM (\_ -> do
ln <- randomRIO (0, num `div` 10) ln <- randomRIO (0, num `div` 10)
(path . (MMNode (V2 0 0) 0 :)) <$> foldM makeVert [] [1 .. ln] path . (MMNode (V2 0 0) 0 :) <$> foldM makeVert [] [1 .. ln]
) )
[0 .. aux] [0 .. aux]
return $ overlays (mainPath : auxPaths) return $ overlays (mainPath : auxPaths)
@ -65,7 +65,7 @@ springField =
(vertexList graph) (vertexList graph)
ngraph = fmap (\n -> fromJust (find ((== mmId n) . mmId) deltaNodes)) graph ngraph = fmap (\n -> fromJust (find ((== mmId n) . mmId) deltaNodes)) graph
in -- A.log A.Debug "\n\nRECURSING\n" in -- A.log A.Debug "\n\nRECURSING\n"
(calcul ngraph) calcul ngraph
else graph else graph
len :: (Floating a, Metric f) => f a -> a len :: (Floating a, Metric f) => f a -> a
@ -138,13 +138,13 @@ calculDelta2 graph =
sproing2 [] = [] sproing2 [] = []
sproing2 ((cnode, cacc):nodeaccs) = sproing2 ((cnode, cacc):nodeaccs) =
( mmId cnode ( mmId cnode
, if (len (V2 100 100 * normv deltasum)) < len deltasum , if len (V2 100 100 * normv deltasum) < len deltasum
then V2 100 100 * normv deltasum then V2 100 100 * normv deltasum
else deltasum else deltasum
) : sproing2 dnodeaccs ) : sproing2 dnodeaccs
where where
deltasum = cacc + sum deltas deltasum = cacc + sum deltas
deltas = map ((fmap (* friction)) . doForce) (map fst nodeaccs) deltas = map (fmap (* friction) . doForce) (map fst nodeaccs)
doForce n doForce n
-- are the nodes identic? (unlikely) -- are the nodes identic? (unlikely)
| mmId cnode == mmId n = | mmId cnode == mmId n =
@ -159,7 +159,7 @@ calculDelta2 graph =
(normv (mmPos cnode - mmPos n)) (normv (mmPos cnode - mmPos n))
-- Do gravitational push in all other cases -- Do gravitational push in all other cases
| otherwise = | otherwise =
- fmap (* (1000 / ((distance (mmPos cnode) (mmPos n)) ^ (2 :: Int)))) - fmap (* (1000 / (distance (mmPos cnode) (mmPos n)) ^ (2 :: Int)))
(normv (mmPos n - mmPos cnode)) (normv (mmPos n - mmPos cnode))
dnodeaccs = zipWith (\(n, a) d -> (n, a - d)) nodeaccs deltas dnodeaccs = zipWith (\(n, a) d -> (n, a - d)) nodeaccs deltas
in accel2 in accel2

22
src/NPC.hs
View file

@ -42,12 +42,12 @@ placeNPCs imgmat tilemat rp count =
c <- randomRIO (1, M.ncols imgmat) c <- randomRIO (1, M.ncols imgmat)
if null (maybe [] collisionObstacle $ imgmat M.! (r, c)) && if null (maybe [] collisionObstacle $ imgmat M.! (r, c)) &&
tilemat M.! (r, c) == Hall tilemat M.! (r, c) == Hall
then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc) then doPlace (nr + 1) (V2 (fromIntegral r) (fromIntegral c) : acc)
else do else do
i <- randomRIO (0, length nonexits - 1) i <- randomRIO (0, length nonexits - 1)
doPlace doPlace
(nr + 1) (nr + 1)
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) (fmap fromIntegral (pointCoord (nonexits !! i)) : acc)
else else
return acc return acc
nonexits = nonexits =
@ -79,7 +79,7 @@ updateNPCs imgmat rp dt = do
e <- queryEnt e <- queryEnt
return (e, pos') return (e, pos')
eaccess <- getObjects npcposs eaccess <- getObjects npcposs
moent <- catMaybes <$> (eover allEnts $ do moent <- catMaybes <$> eover allEnts (do
with pos with pos
with npcMoveState with npcMoveState
with vel with vel
@ -93,7 +93,7 @@ updateNPCs imgmat rp dt = do
let nttl = ttl - dt let nttl = ttl - dt
if nttl > 0 if nttl > 0
then then
return $ (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCStanding nttl future { npcMoveState = Set $ NPCStanding nttl future
, vel = Set $ V2 0 0 , vel = Set $ V2 0 0
}) })
@ -101,24 +101,24 @@ updateNPCs imgmat rp dt = do
mpath <- liftIO $ tryTakeMVar future mpath <- liftIO $ tryTakeMVar future
case mpath of case mpath of
Just path -> Just path ->
return $ (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCWalking path { npcMoveState = Set $ NPCWalking path
}) })
Nothing -> Nothing ->
return $ (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCStanding 1 future { npcMoveState = Set $ NPCStanding 1 future
}) })
NPCWalking path -> do NPCWalking path ->
if not (null path) if not (null path)
then do then do
let itarget = V2 0.5 0.5 + (fromIntegral <$> head path) :: V2 Double let itarget = V2 0.5 0.5 + (fromIntegral <$> head path) :: V2 Double
if distance pos' itarget < 0.1 if distance pos' itarget < 0.1
then then
return $ (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCWalking (tail path) { npcMoveState = Set $ NPCWalking (tail path)
}) })
else else
return $ (Nothing, unchanged return (Nothing, unchanged
{ vel = Set $ (* 2) <$> signorm (itarget - pos') { vel = Set $ (* 2) <$> signorm (itarget - pos')
}) })
else do else do
@ -128,12 +128,12 @@ updateNPCs imgmat rp dt = do
getPath (fmap floor pos') future rp imgmat posbounds getPath (fmap floor pos') future rp imgmat posbounds
e <- queryEnt e <- queryEnt
let mdir = let mdir =
(pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp) pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp
accessibles = fromMaybe [] $ lookup e eaccess accessibles = fromMaybe [] $ lookup e eaccess
case accessibles of case accessibles of
[] -> do [] -> do
ttl <- liftIO $ randomRIO (5, 30) ttl <- liftIO $ randomRIO (5, 30)
return $ (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCStanding ttl future { npcMoveState = Set $ NPCStanding ttl future
, vel = Set $ V2 0 0 , vel = Set $ V2 0 0
, rot = Set $ fromMaybe rot' mdir , rot = Set $ fromMaybe rot' mdir

6
src/Navigation.hs
View file

@ -18,7 +18,7 @@ isReachable
-> Bool -> Bool
isReachable imgmat animBounds reaches exits = isReachable imgmat animBounds reaches exits =
let result = let result =
(concatMap concatMap
(\exit -> map (astarAppl imgmat animBounds exit) reaches) ((\exit -> map (astarAppl imgmat animBounds exit) reaches) . pointCoord)
(map pointCoord exits)) exits
in all isJust result in all isJust result

12
src/Object.hs
View file

@ -25,7 +25,7 @@ instance ObjectAction ObjType ObjState where
{ objStateTime = Set (actionTime t s) { objStateTime = Set (actionTime t s)
, objState = Set "copying" , objState = Set "copying"
} }
Just ttl -> do Just ttl ->
return unchanged return unchanged
{ objStateTime = Set (ttl - dt) { objStateTime = Set (ttl - dt)
} }
@ -50,7 +50,7 @@ instance ObjectAction ObjType ObjState where
return unchanged return unchanged
{ objStateTime = Set dur { objStateTime = Set dur
} }
Just ttl -> do Just ttl ->
return unchanged return unchanged
{ objStateTime = Set (ttl - dt) { objStateTime = Set (ttl - dt)
} }
@ -60,10 +60,10 @@ instance ObjectAction ObjType ObjState where
Nothing -> return Nothing Nothing -> return Nothing
Just ttl -> do Just ttl -> do
pa <- query objPlayerActivated pa <- query objPlayerActivated
if (ttl < 0) if ttl < 0
then do then
return (Just pa) return (Just pa)
else if (pa && vl `dot` vl > 0) else if pa && vl `dot` vl > 0
then return (Just pa) then return (Just pa)
else return Nothing else return Nothing
maybe maybe
@ -84,7 +84,7 @@ instance ObjectAction ObjType ObjState where
return unchanged return unchanged
{ objStateTime = Set (actionTime t s) { objStateTime = Set (actionTime t s)
} }
Just ttl -> do Just ttl ->
return unchanged return unchanged
{ objStateTime = Set (ttl - dt) { objStateTime = Set (ttl - dt)
} }

26
src/Util.hs
View file

@ -32,8 +32,10 @@ convertTileToImg :: Matrix TileState -> Matrix (Maybe ImgId)
convertTileToImg mat = fromLists conversion convertTileToImg mat = fromLists conversion
where where
conversion = conversion =
map (\(i, ls) -> map (uncurry $ convertTile i) (zip [1..] ls)) zipWith
(zip [1..] (toLists mat)) (\i ls -> zipWith (convertTile i) [1..] ls)
[1..]
(toLists mat)
convertTile irow icol tile = convertTile irow icol tile =
case tile of case tile of
Wall -> Just (case neighWalls irow icol mat of Wall -> Just (case neighWalls irow icol mat of
@ -148,7 +150,7 @@ astarAppl imgmat animBounds target = aStar
(fmap (fromIntegral :: Int -> Double) a) (fmap (fromIntegral :: Int -> Double) a)
(fmap (fromIntegral :: Int -> Double) b) (fmap (fromIntegral :: Int -> Double) b)
) )
(\a -> distance (fmap fromIntegral target) (fmap fromIntegral a)) (distance (fmap fromIntegral target) . fmap fromIntegral)
(== target) (== target)
naviGraph naviGraph
@ -161,9 +163,9 @@ naviGraph imgmat animBounds (V2 r c) =
foldl foldl
(\acc (rr, cc) -> (\acc (rr, cc) ->
if null if null
((maybe [] collisionObstacle (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat)) ++ (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat) ++
(map snd $ filter map snd (filter
(\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc) (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds)) animBounds))
then V2 (r + rr) (c + cc): acc then V2 (r + rr) (c + cc): acc
@ -175,16 +177,16 @@ naviGraph imgmat animBounds (V2 r c) =
foldl foldl
(\acc (rr, cc) -> (\acc (rr, cc) ->
if null if null
((maybe [] collisionObstacle (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat)) ++ (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat) ++
(map snd $ filter map snd (filter
(\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc) (\(V2 br bc, _) -> floor br == r + rr && floor bc == c + cc)
animBounds)) animBounds))
&& all null && all null
(map (map
(\(oor, ooc) -> (maybe [] collisionObstacle (\(oor, ooc) -> (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + oor) (c + ooc) imgmat)) ++ (fromMaybe Nothing $ M.safeGet (r + oor) (c + ooc) imgmat)) ++
(map snd $ filter map snd (filter
(\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc) (\(V2 br bc, _) -> floor br == r + oor && floor bc == c + ooc)
animBounds)) animBounds))
[(0, cc), (rr, 0)]) [(0, cc), (rr, 0)])
@ -227,7 +229,7 @@ loadAnimationSprites fp nvg idconfs = do
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
mapM mapM
(\(i, (AnimationConfig (xoffs, yoffs) (w, h) (sx, sy) count dur pb)) -> do (\(i, AnimationConfig (xoffs, yoffs) (w, h) (sx, sy) count dur pb) -> do
let crs = map let crs = map
(\iid -> crop (xoffs + (iid * sx)) (yoffs + (iid * sy)) w h img) (\iid -> crop (xoffs + (iid * sx)) (yoffs + (iid * sy)) w h img)
[0 .. (count - 1)] [0 .. (count - 1)]
@ -242,7 +244,7 @@ loadAnimationSprites fp nvg idconfs = do
exitFailure exitFailure
else else
return $ catMaybes mresimgs return $ catMaybes mresimgs
return $ return
( i ( i
, Animation dur imgs pb , Animation dur imgs pb
) )