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

linting and de-warning

Browse source
This commit is contained in:
nek0 2018-07-03 16:19:27 +02:00
parent f74ce66e2f
commit 690179e4ec
14 changed files with 80 additions and 122 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
src/Floorplan.hs
View file

@ -11,8 +11,6 @@ import System.Random
import Types.Map import Types.Map
import Debug.Trace
buildHallFloorIO buildHallFloorIO
:: FloorConfig :: FloorConfig
-> MVar Float -> MVar Float
@ -68,6 +66,13 @@ placeHalls rng fc input =
[Boundaries (1,1) (nrows input, ncols input)] [Boundaries (1,1) (nrows input, ncols input)]
(fcElevator fc) 5 input (fcElevator fc) 5 input
where where
doHalls
:: StdGen
-> [Boundaries Int]
-> (Int , Int)
-> Int
-> Matrix TileState
-> (StdGen, Matrix TileState)
doHalls rand bs cross wmax mat = doHalls rand bs cross wmax mat =
foldl (\(agen, amat) b -> foldl (\(agen, amat) b ->
let (row, g1) = randomR let (row, g1) = randomR
@ -358,7 +363,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 = do buildDoors input graph =
foldM placeDoors input graph foldM placeDoors input graph
where where
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
@ -425,9 +430,9 @@ buildDoors input graph = do
(M.toList (M.submatrix (row - 1) (row + 1) col col mat))) (M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
== 1 == 1
then then
if Door `elem` M.toList (M.submatrix row row (fst cols) (snd cols) mat) if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
then return mat then return mat
else do else
return $ M.setElem Door (row, col) mat return $ M.setElem Door (row, col) mat
else else
inRow mat row cols inRow mat row cols
@ -441,9 +446,9 @@ buildDoors input graph = do
(M.toList (M.submatrix row row (col - 1) (col + 1) mat))) (M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
== 1 == 1
then then
if Door `elem` M.toList (M.submatrix (fst rows) (snd rows) col col mat) if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
then return mat then return mat
else do else
return $ M.setElem Door (row, col) mat return $ M.setElem Door (row, col) mat
else else
inCol mat rows col inCol mat rows col

25
src/Init.hs
View file

@ -4,28 +4,17 @@ module Init where
import Affection as A import Affection as A
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import NanoVG hiding (V2(..), V3(..)) import NanoVG hiding (V2(..), V3(..))
import NanoVG.Internal.Image (ImageFlags(..)) import NanoVG.Internal.Image (ImageFlags(..))
import Linear hiding (E(..))
import Codec.Picture as CP import Codec.Picture as CP
import Codec.Picture.Extra import Codec.Picture.Extra
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import Data.Ecstasy import Data.Ecstasy
import Data.Maybe
import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy (toStrict)
import System.Exit (exitFailure) import System.Exit (exitFailure)
@ -34,10 +23,6 @@ import Foreign.C.Types (CInt(..))
import Types import Types
import Floorplan
import Debug.Trace
foreign import ccall unsafe "glewInit" foreign import ccall unsafe "glewInit"
glewInit :: IO CInt glewInit :: IO CInt
@ -79,16 +64,16 @@ loadPlayerSprite fp w h nvg rids = do
exitFailure exitFailure
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
ret <- mapM (\(row, ids) -> do ret <- mapM (\(row, ids) ->
mapM (\(num, id) -> do mapM (\(num, i) -> do
let cr = crop (num * w) (row * h) w h img let cr = crop (num * w) (row * h) w h img
mresimg <- mresimg <-
createImageMem nvg (ImagePremultiplied) (toStrict $ encodePng cr) createImageMem nvg ImagePremultiplied (toStrict $ encodePng cr)
case mresimg of case mresimg of
Nothing -> do Nothing -> do
logIO Error ("Failed to load: " ++ fp ++ " " ++ show id) logIO Error ("Failed to load: " ++ fp ++ " " ++ show i)
exitFailure exitFailure
Just resimg -> return (id, resimg) Just resimg -> return (i, resimg)
) (zip [0..] ids) ) (zip [0..] ids)
) rids ) rids
return $ concat ret return $ concat ret

14
src/Interior.hs
View file

@ -1,7 +1,5 @@
module Interior where module Interior where
import Affection as A
import Data.Matrix as M import Data.Matrix as M
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.List as L import Data.List as L
@ -40,15 +38,15 @@ placeInteriorIO imat imgmat irp graph =
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint])) -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph acc (GHall sub) = traverseGraph acc (GHall sub) =
foldl traverseGraph acc sub foldl traverseGraph acc sub
traverseGraph put@(rng, (mat, rp)) (GRoom _ bnds) = traverseGraph putt@(_, _) (GRoom _ bnds) =
let applicable = let applicable =
reverse (L.sortBy (\a b -> size a `compare` size b) ( (L.sortBy (\b a -> size a `compare` size b) (
L.filter L.filter
(\a -> clusterRoom a == roomType && size a <= size bnds) (\a -> clusterRoom a == roomType && size a <= size bnds)
[minBound .. maxBound] :: [Cluster]) [minBound .. maxBound] :: [Cluster])
) )
roomType = fst (head $ reverse $ L.sortBy roomType = fst (head $ L.sortBy
(\a b -> snd a `compare` snd b) $ 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
else Map.insert a 1 acc else Map.insert a 1 acc
@ -63,7 +61,7 @@ placeInteriorIO imat imgmat irp graph =
in in
foldl foldl
(\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp) (\(orng, (omat, orp)) -> placeCluster orng bnds 1 omat orp)
put putt
applicable applicable
placeCluster placeCluster
:: StdGen :: StdGen
@ -83,7 +81,7 @@ placeInteriorIO imat imgmat irp graph =
(fst $ matmin bnds) (fst $ matmax bnds) (fst $ matmin bnds) (fst $ matmax bnds)
(snd $ matmin bnds) (snd $ matmax bnds) (snd $ matmin bnds) (snd $ matmax bnds)
mat mat
) ) :: Int
cmat = clusterMat appl cmat = clusterMat appl
newmat = insertMat cmat mat (pr, pc) newmat = insertMat cmat mat (pr, pc)
exits = filter exits = filter

13
src/Load.hs
View file

@ -33,8 +33,8 @@ loadLoad = do
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
loadFork loadFork
(worldState ud) (worldState ud)
(window ud) (fromJust $ window ud)
(threadContext ud) (fromJust $ threadContext ud)
(nano ud) (nano ud)
future future
progress progress
@ -50,13 +50,13 @@ loadLoad = do
loadFork loadFork
:: (SystemState Entity IO) :: (SystemState Entity IO)
-> Maybe SDL.Window -> SDL.Window
-> Maybe SDL.GLContext -> SDL.GLContext
-> Context -> Context
-> MVar (SystemState Entity IO, StateData) -> MVar (SystemState Entity IO, StateData)
-> MVar Float -> MVar Float
-> IO () -> IO ()
loadFork ws (Just win) (Just glc) nvg future progress = do loadFork ws win glc nvg future progress = do
let stateSteps = 22 let stateSteps = 22
increment = 1 / stateSteps increment = 1 / stateSteps
SDL.glMakeCurrent win glc SDL.glMakeCurrent win glc
@ -141,7 +141,6 @@ loadFork ws (Just win) (Just glc) nvg future progress = do
drawLoad :: Affection UserData () drawLoad :: Affection UserData ()
drawLoad = do drawLoad = do
ud <- getAffection ud <- getAffection
let ctx = nano ud
progress <- liftIO $ readMVar (stateProgress ud) progress <- liftIO $ readMVar (stateProgress ud)
liftIO $ do liftIO $ do
logIO A.Verbose ("LoadProgress: " ++ show progress) logIO A.Verbose ("LoadProgress: " ++ show progress)
@ -161,5 +160,5 @@ updateLoad _ = do
, stateData = None , stateData = None
} }
loadMap loadMap
Nothing -> do Nothing ->
return () return ()

7
src/Main.hs
View file

@ -6,7 +6,6 @@ import Affection as A
import qualified SDL import qualified SDL
import NanoVG hiding (V2(..), V3(..)) import NanoVG hiding (V2(..), V3(..))
import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Linear import Linear
@ -51,13 +50,13 @@ pre = do
ad <- A.get ad <- A.get
ud <- getAffection ud <- getAffection
-- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1 -- _ <- SDL.glSetAttribute SDL.SDL_GL_SHARE_WITH_CURRENT_CONTEXT 1
threadContext <- SDL.glCreateContext (drawWindow ad) threadCtx <- SDL.glCreateContext (drawWindow ad)
SDL.glMakeCurrent (drawWindow ad) (glContext ad) SDL.glMakeCurrent (drawWindow ad) (glContext ad)
Subsystems w m k <- subsystems <$> getAffection Subsystems w m k <- subsystems <$> getAffection
_ <- partSubscribe w (fitViewport (1280/720)) _ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w exitOnWindowClose _ <- partSubscribe w exitOnWindowClose
putAffection ud putAffection ud
{ threadContext = Just threadContext { threadContext = Just threadCtx
, mainContext = Just (glContext ad) , mainContext = Just (glContext ad)
, window = Just (drawWindow ad) , window = Just (drawWindow ad)
} }
@ -86,5 +85,5 @@ exitOnWindowClose (MsgWindowClose _ _) = do
exitOnWindowClose _ = return () exitOnWindowClose _ = return ()
clean :: UserData -> IO () clean :: UserData -> IO ()
clean ud = do clean ud =
SDL.glDeleteContext $ fromJust $ threadContext ud SDL.glDeleteContext $ fromJust $ threadContext ud

9
src/MainGame/MindMap.hs
View file

@ -12,14 +12,8 @@ import Data.List as L
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe import Data.Maybe
import Control.Monad (when)
import NanoVG hiding (V2(..)) import NanoVG hiding (V2(..))
import SDL hiding (E(..))
import Foreign.C.Types
-- internal imports -- internal imports
import Types import Types
@ -130,7 +124,6 @@ updateMind dt = do
} }
} }
x -> error ("unknown animation name" ++ x) x -> error ("unknown animation name" ++ x)
len = sqrt (dpos `dot` dpos)
lll = (,) lll = (,)
<$> ( <$> (
if dpr < 0 if dpr < 0
@ -214,7 +207,7 @@ drawMind = do
:: [(V2 Double, AnimState)] :: [(V2 Double, AnimState)]
-> (Int, Int) -> (Int, Int)
-> ([(V2 Double, AnimState)], [(V2 Double, AnimState)]) -> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
processList list coord@(r, c) = processList list (r, c) =
let delimiter (V2 nr nc, _) = let delimiter (V2 nr nc, _) =
floor nr == r && floor nc == c floor nr == r && floor nc == c
in L.partition delimiter list in L.partition delimiter list

36
src/MainGame/WorldMap.hs
View file

@ -41,10 +41,9 @@ loadMap :: Affection UserData ()
loadMap = do loadMap = do
ud <- getAffection ud <- getAffection
let (Subsystems _ m k) = subsystems ud let (Subsystems _ m k) = subsystems ud
ctx = nano ud
uu1 <- partSubscribe m movePlayer uu1 <- partSubscribe m movePlayer
uu2 <- partSubscribe k changeMaps uu2 <- partSubscribe k changeMaps
future <- liftIO $ newEmptyMVar future <- liftIO newEmptyMVar
progress <- liftIO $ newMVar 0 progress <- liftIO $ newMVar 0
_ <- liftIO $ forkIO $ loadMapFork ud future progress _ <- liftIO $ forkIO $ loadMapFork ud future progress
putAffection ud putAffection ud
@ -96,30 +95,30 @@ loadMapFork ud future progress = do
_ <- liftIO $ swapMVar progress (13 / loadSteps) _ <- liftIO $ swapMVar progress (13 / loadSteps)
logIO A.Debug ("number of reachpoints: " ++ show (length rps)) logIO A.Debug ("number of reachpoints: " ++ show (length rps))
let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
npcposs <- placeNPCs inter mat rps gr 50 -- (length nnex) npcposs <- placeNPCs inter mat rps 50 -- (length nnex)
_ <- liftIO $ swapMVar progress (14 / loadSteps) _ <- liftIO $ swapMVar progress (14 / loadSteps)
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) 3 buildMindMap (length npcposs) 3
_ <- liftIO $ swapMVar progress (15 / loadSteps) _ <- liftIO $ swapMVar progress (15 / loadSteps)
let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat let mmimgmat = convertTileToImg $ manhattan mmgraph mmintmat
_ <- liftIO $ swapMVar progress (16 / loadSteps) _ <- liftIO $ swapMVar progress (16 / loadSteps)
(nws, _) <- yieldSystemT (worldState ud) $ do (nws, _) <- yieldSystemT (worldState ud) $ do
let pmmpos = ((+ 0.5) . fromIntegral . floor) <$> mmPos let pmmpos = (+ 0.5) . (fromIntegral :: Int -> Double) . floor <$> mmPos
(fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph)) (fromJust $ find (\a -> mmId a == 0) (vertexList mmgraph))
delta = [(0, 0)] ++ delta = (0, 0) :
Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)] Prelude.filter (/= (0,0)) ((,) <$> [-1 .. 1] <*> [-1 .. 1]) :: [(Int, Int)]
mmpos = Prelude.foldl (\acc (dr, dc) -> mmmpos = Prelude.foldl (\acc (dr, dc) ->
let (V2 pmr pmc) = floor <$> pmmpos let (V2 pmr pmc) = floor <$> pmmpos
seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc) seekpos = (pmr + fromIntegral dr, pmc + fromIntegral dc)
in if mmimgmat M.! seekpos == Nothing && mmintmat M.! seekpos == 0 in if isNothing (mmimgmat M.! seekpos) && mmintmat M.! seekpos == 0
&& acc == Nothing && isNothing acc
then Just (pmmpos + (fromIntegral <$> V2 dr dc)) then Just (pmmpos + (fromIntegral <$> V2 dr dc))
else acc else acc
) Nothing delta ) Nothing delta
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 10.5 10.5) { pos = Just (V2 10.5 10.5)
, mmpos = mmpos , mmpos = mmmpos
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, mmvel = Just (V2 0 0) , mmvel = Just (V2 0 0)
, player = Just () , player = Just ()
@ -128,16 +127,16 @@ loadMapFork ud future progress = do
, anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 0 "standing" SE) 0 0
} }
void $ liftIO $ swapMVar progress (17 / loadSteps) void $ liftIO $ swapMVar progress (17 / loadSteps)
void $ mapM_ (\npcpos@(V2 nr nc) -> do mapM_ (\npcpos@(V2 nr nc) -> do
fact <- liftIO $ randomRIO (0.5, 1.5) fact <- liftIO $ randomRIO (0.5, 1.5)
future <- liftIO newEmptyMVar fut <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) fut nnex inter
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (V2 (nr + 0.5) (nc + 0.5)) { pos = Just (V2 (nr + 0.5) (nc + 0.5))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, velFact = Just fact , velFact = Just fact
, rot = Just SE , rot = Just SE
, npcMoveState = Just (NPCStanding 0 future) , npcMoveState = Just (NPCStanding 0 fut)
, anim = Just $ AnimState (AnimId 1 "standing" SE) 0 0 , anim = Just $ AnimState (AnimId 1 "standing" SE) 0 0
} }
) npcposs ) npcposs
@ -235,7 +234,7 @@ drawMap = do
:: [(V2 Double, AnimState)] :: [(V2 Double, AnimState)]
-> (Int, Int) -> (Int, Int)
-> ([(V2 Double, AnimState)], [(V2 Double, AnimState)]) -> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
processList list coord@(r, c) = processList list (r, c) =
let delimiter (V2 nr nc, _) = let delimiter (V2 nr nc, _) =
floor nr == r && floor nc == c floor nr == r && floor nc == c
in L.partition delimiter list in L.partition delimiter list
@ -297,12 +296,10 @@ drawTile ud ctx posanims pr pc row col img =
nnr > fst (matmax b) nnr > fst (matmax b)
| otherwise = | otherwise =
True True
nnr = nr - fromIntegral (floor nr) nnr = nr - fromIntegral ((floor nr) :: Int) :: Double
nnc = nc - fromIntegral (floor nc) nnc = nc - fromIntegral ((floor nc) :: Int) :: Double
-- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs && -- any (\m -> nr < fromIntegral (floor nr :: Int) + m) maxrs &&
-- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs -- any (\m -> nc > fromIntegral (floor nc :: Int) + m) mincs
ai = assetImages ud
anims = assetAnimations ud
tileWidth = 64 :: Double tileWidth = 64 :: Double
tileHeight = 32 :: Double tileHeight = 32 :: Double
sorted = sortOn (\(V2 sr sc, _) -> sc + sr * fromIntegral col) posanims sorted = sortOn (\(V2 sr sc, _) -> sc + sr * fromIntegral col) posanims
@ -494,7 +491,6 @@ updateMap dt = do
} }
} }
x -> error ("unknown animation name" ++ x) x -> error ("unknown animation name" ++ x)
len = sqrt (dpos `dot` dpos)
lll = (,) lll = (,)
<$> ( <$> (
if dpr < 0 if dpr < 0

22
src/MindMap.hs
View file

@ -51,8 +51,8 @@ buildMindMap num difficulty = do
else return (node : acc) else return (node : acc)
springField :: AG.Graph MMNode -> AG.Graph MMNode springField :: AG.Graph MMNode -> AG.Graph MMNode
springField inGraph = springField =
calcul inGraph calcul
where where
-- This could be optimized in such a way, that you update both computation partners at once. -- This could be optimized in such a way, that you update both computation partners at once.
calculDelta :: AG.Graph MMNode -> MMNode -> (Int, V2 Double) calculDelta :: AG.Graph MMNode -> MMNode -> (Int, V2 Double)
@ -117,24 +117,20 @@ manhattan :: AG.Graph MMNode -> M.Matrix Int -> M.Matrix TileState
manhattan graph input = manhattan graph input =
walls intermediate walls intermediate
where where
distance :: (Int, Int) -> (Int, Int) -> Int mandistance :: (Int, Int) -> (Int, Int) -> Int
distance (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2) mandistance (r1, c1) (r2, c2) = abs (r1 - r2) + abs (c1 - c2)
dmin = M.nrows input + M.ncols input dmin = M.nrows input + M.ncols input
calculate (r, c) = foldl (\acc@(accdmin, accind) (MMNode (V2 vr vc) ind) -> calculate (r, c) = foldl (\acc@(accdmin, _) (MMNode (V2 vr vc) ind) ->
let d = distance (r, c) (floor vr, floor vc) let d = mandistance (r, c) (floor vr, floor vc)
in if d < accdmin in if d < accdmin
then (d, ind) then (d, ind)
else acc else acc
) (dmin, 0) vertices ) (dmin, 0) verts
vertices = vertexList graph verts = vertexList graph
coords = (,) <$> [1 .. M.nrows input] <*> [1 .. M.ncols input] coords = (,) <$> [1 .. M.nrows input] <*> [1 .. M.ncols input]
intermediate = M.matrix (M.nrows input) (M.ncols input) (snd . calculate) intermediate = M.matrix (M.nrows input) (M.ncols input) (snd . calculate)
walls inter = foldl (\accmat (r, c) -> walls inter = foldl (\accmat (r, c) ->
let neighbNodes d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) inter) d wallnotwall inter accmat r c
neighbWalls d = map (\(rr, cc) -> M.safeGet (r + rr) (c + cc) accmat) d
cross = [(0, 1), (0, -1), (1, 0), (-1, 0)]
deltas = ((,) <$> [(-1) .. 1] <*> [(-1) .. 1])
in wallnotwall inter accmat r c
) emptyMM coords ) emptyMM coords
emptyMM = M.matrix (M.nrows input) (M.ncols input) (const Offi) emptyMM = M.matrix (M.nrows input) (M.ncols input) (const Offi)
wallnotwall inter mat r c wallnotwall inter mat r c

17
src/NPC.hs
View file

@ -3,7 +3,6 @@ module NPC where
import Affection as A import Affection as A
import qualified Data.Matrix as M import qualified Data.Matrix as M
import Data.Map.Strict as Map hiding (filter, null)
import Data.Ecstasy as E import Data.Ecstasy as E
import Data.Maybe (fromMaybe) import Data.Maybe (fromMaybe)
import Data.List (find) import Data.List (find)
@ -16,11 +15,8 @@ import Linear
import System.Random import System.Random
import NanoVG hiding (V2(..))
-- internal imports -- internal imports
import Navigation
import Util import Util
import Types import Types
@ -29,14 +25,13 @@ placeNPCs
:: M.Matrix (Maybe ImgId) :: M.Matrix (Maybe ImgId)
-> M.Matrix TileState -> M.Matrix TileState
-> [ReachPoint] -> [ReachPoint]
-> [Graph]
-> Int -> Int
-> IO [V2 Double] -> IO [V2 Double]
placeNPCs imgmat tilemat rp gr count = placeNPCs imgmat tilemat rp count =
doPlace 1 [] doPlace 1 []
where where
doPlace :: Int -> [V2 Double] -> IO [V2 Double] doPlace :: Int -> [V2 Double] -> IO [V2 Double]
doPlace nr acc = do doPlace nr acc =
if nr <= count if nr <= count
then do then do
r <- randomRIO (1, M.nrows imgmat) r <- randomRIO (1, M.nrows imgmat)
@ -51,8 +46,6 @@ placeNPCs imgmat tilemat rp gr count =
((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc)
else else
return acc return acc
applRooms row col =
(filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr)
nonexits = nonexits =
filter filter
(\p -> (\p ->
@ -112,7 +105,7 @@ updateNPCs imgmat rp dt =
ttl <- liftIO $ randomRIO (5, 30) ttl <- liftIO $ randomRIO (5, 30)
future <- liftIO $ newEmptyMVar future <- liftIO $ newEmptyMVar
rot' <- query rot rot' <- query rot
state <- query anim stat <- query anim
let mdir = let mdir =
(pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp) (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
-- _ <- liftIO $ forkOS $ getPath (fmap floor pos') future rp imgmat -- _ <- liftIO $ forkOS $ getPath (fmap floor pos') future rp imgmat
@ -121,8 +114,8 @@ updateNPCs imgmat rp dt =
{ 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
, anim = Set state , anim = Set stat
{ asId = (asId state) { asId = (asId stat)
{ aiDirection = fromMaybe rot' mdir { aiDirection = fromMaybe rot' mdir
} }
} }

3
src/Navigation.hs
View file

@ -3,11 +3,8 @@ module Navigation where
import Affection as A import Affection as A
import Data.Matrix as M import Data.Matrix as M
import qualified Data.HashSet as HS
import Data.Maybe (isJust) import Data.Maybe (isJust)
import Linear
-- internal imports -- internal imports
import Types import Types

2
src/Types/Drawable.hs
View file

@ -2,8 +2,6 @@
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
module Types.Drawable where module Types.Drawable where
import Affection as A
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import NanoVG import NanoVG

1
src/Types/Interior.hs
View file

@ -7,7 +7,6 @@ import Linear.V2
-- internal imports -- internal imports
import Types.Map import Types.Map
import Types.UserData
import Types.ReachPoint import Types.ReachPoint
import Types.ImgId import Types.ImgId
import Types.Direction import Types.Direction

2
src/Types/UserData.hs
View file

@ -13,7 +13,6 @@ import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Matrix
import Data.Ecstasy import Data.Ecstasy
import Control.Concurrent.MVar import Control.Concurrent.MVar
@ -45,7 +44,6 @@ data UserData = UserData
data State data State
= Load = Load
| Main SubMain | Main SubMain
| Test
data SubMain data SubMain
= WorldMap = WorldMap

32
src/Util.hs
View file

@ -136,37 +136,39 @@ inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) =
(r >= minr && r <= maxr) && (c >= minc && c <= maxc) (r >= minr && r <= maxr) && (c >= minc && c <= maxc)
astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int] astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int]
astarAppl imgmat target start = aStar astarAppl imgmat target = aStar
(naviGraph imgmat) (naviGraph imgmat)
(\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b)) (\a b -> distance
(fmap (fromIntegral :: Int -> Double) a)
(fmap (fromIntegral :: Int -> Double) b)
)
(\a -> distance (fmap fromIntegral target) (fmap fromIntegral a)) (\a -> distance (fmap fromIntegral target) (fmap fromIntegral a))
(== target) (== target)
start
naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int) naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int)
naviGraph imgmat (V2 r c) = naviGraph imgmat (V2 r c) =
let list1 = let list1 =
foldl foldl
(\acc (or, oc) -> (\acc (rr, cc) ->
if null if null
(maybe [] collisionObstacle (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + or) (c + oc) imgmat)) (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat))
then V2 (r + or) (c + oc): acc then V2 (r + rr) (c + cc): acc
else acc else acc
) )
[] []
[(0, 1), (0, -1), (1, 0), (-1, 0)] [(0, 1), (0, -1), (1, 0), (-1, 0)]
list2 = list2 =
foldl foldl
(\acc (or, oc) -> (\acc (rr, cc) ->
if null (maybe [] collisionObstacle if null (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + or) (c + oc) imgmat)) (fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat))
&& 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))
[(0, oc), (or, 0)]) [(0, cc), (rr, 0)])
then V2 (r + or) (c + oc): acc then V2 (r + rr) (c + cc): acc
else acc else acc
) )
[] []
@ -203,23 +205,23 @@ loadAnimationSprites fp nvg idconfs = do
Right dimg -> do Right dimg -> do
let img = convertRGBA8 dimg let img = convertRGBA8 dimg
mapM mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do (\(i, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map let crs = map
(\i -> crop (xoffs + (i * w)) yoffs w h img) (\iid -> crop (xoffs + (iid * w)) yoffs w h img)
[0 .. (count - 1)] [0 .. (count - 1)]
mresimgs <- mapM mresimgs <- mapM
(\cr -> (\cr ->
createImageMem nvg createImageMem nvg
(ImagePremultiplied) (toStrict $ encodePng cr)) ImagePremultiplied (toStrict $ encodePng cr))
crs crs
imgs <- if any isNothing mresimgs imgs <- if any isNothing mresimgs
then do then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show id) logIO Error ("failed to load: " ++ fp ++ " " ++ show i)
exitFailure exitFailure
else else
return $ catMaybes mresimgs return $ catMaybes mresimgs
return $ return $
( id ( i
, Animation dur imgs pb , Animation dur imgs pb
) )
) idconfs ) idconfs