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 Debug.Trace
buildHallFloorIO
:: FloorConfig
-> MVar Float
@ -68,6 +66,13 @@ placeHalls rng fc input =
[Boundaries (1,1) (nrows input, ncols input)]
(fcElevator fc) 5 input
where
doHalls
:: StdGen
-> [Boundaries Int]
-> (Int , Int)
-> Int
-> Matrix TileState
-> (StdGen, Matrix TileState)
doHalls rand bs cross wmax mat =
foldl (\(agen, amat) b ->
let (row, g1) = randomR
@ -358,7 +363,7 @@ buildDoorsGraph mat =
in buildGraph mat [GHall []] (2, 2)
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors input graph = do
buildDoors input graph =
foldM placeDoors input graph
where
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)))
== 1
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
else do
else
return $ M.setElem Door (row, col) mat
else
inRow mat row cols
@ -441,9 +446,9 @@ buildDoors input graph = do
(M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
== 1
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
else do
else
return $ M.setElem Door (row, col) mat
else
inCol mat rows col

25
src/Init.hs
View file

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

14
src/Interior.hs
View file

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

13
src/Load.hs
View file

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

7
src/Main.hs
View file

@ -6,7 +6,6 @@ import Affection as A
import qualified SDL
import NanoVG hiding (V2(..), V3(..))
import Graphics.Rendering.OpenGL.GL.FlushFinish (finish)
import Linear
@ -51,13 +50,13 @@ pre = do
ad <- A.get
ud <- getAffection
-- _ <- 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)
Subsystems w m k <- subsystems <$> getAffection
_ <- partSubscribe w (fitViewport (1280/720))
_ <- partSubscribe w exitOnWindowClose
putAffection ud
{ threadContext = Just threadContext
{ threadContext = Just threadCtx
, mainContext = Just (glContext ad)
, window = Just (drawWindow ad)
}
@ -86,5 +85,5 @@ exitOnWindowClose (MsgWindowClose _ _) = do
exitOnWindowClose _ = return ()
clean :: UserData -> IO ()
clean ud = do
clean 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.Maybe
import Control.Monad (when)
import NanoVG hiding (V2(..))
import SDL hiding (E(..))
import Foreign.C.Types
-- internal imports
import Types
@ -130,7 +124,6 @@ updateMind dt = do
}
}
x -> error ("unknown animation name" ++ x)
len = sqrt (dpos `dot` dpos)
lll = (,)
<$> (
if dpr < 0
@ -214,7 +207,7 @@ drawMind = do
:: [(V2 Double, AnimState)]
-> (Int, Int)
-> ([(V2 Double, AnimState)], [(V2 Double, AnimState)])
processList list coord@(r, c) =
processList list (r, c) =
let delimiter (V2 nr nc, _) =
floor nr == r && floor nc == c
in L.partition delimiter list

36
src/MainGame/WorldMap.hs
View file

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

22
src/MindMap.hs
View file

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

17
src/NPC.hs
View file

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

3
src/Navigation.hs
View file

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

2
src/Types/Drawable.hs
View file

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

1
src/Types/Interior.hs
View file

@ -7,7 +7,6 @@ import Linear.V2
-- internal imports
import Types.Map
import Types.UserData
import Types.ReachPoint
import Types.ImgId
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.Text as T
import Data.Matrix
import Data.Ecstasy
import Control.Concurrent.MVar
@ -45,7 +44,6 @@ data UserData = UserData
data State
= Load
| Main SubMain
| Test
data SubMain
= 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)
astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int]
astarAppl imgmat target start = aStar
astarAppl imgmat target = aStar
(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))
(== target)
start
naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int)
naviGraph imgmat (V2 r c) =
let list1 =
foldl
(\acc (or, oc) ->
(\acc (rr, cc) ->
if null
(maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + or) (c + oc) imgmat))
then V2 (r + or) (c + oc): acc
(fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat))
then V2 (r + rr) (c + cc): acc
else acc
)
[]
[(0, 1), (0, -1), (1, 0), (-1, 0)]
list2 =
foldl
(\acc (or, oc) ->
(\acc (rr, cc) ->
if null (maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + or) (c + oc) imgmat))
(fromMaybe Nothing $ M.safeGet (r + rr) (c + cc) imgmat))
&& all null
(map
(\(oor, ooc) -> maybe [] collisionObstacle
(fromMaybe Nothing $ M.safeGet (r + oor) (c + ooc) imgmat))
[(0, oc), (or, 0)])
then V2 (r + or) (c + oc): acc
[(0, cc), (rr, 0)])
then V2 (r + rr) (c + cc): acc
else acc
)
[]
@ -203,23 +205,23 @@ loadAnimationSprites fp nvg idconfs = do
Right dimg -> do
let img = convertRGBA8 dimg
mapM
(\(id, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
(\(i, (AnimationConfig (xoffs, yoffs) (w, h) count dur pb)) -> do
let crs = map
(\i -> crop (xoffs + (i * w)) yoffs w h img)
(\iid -> crop (xoffs + (iid * w)) yoffs w h img)
[0 .. (count - 1)]
mresimgs <- mapM
(\cr ->
createImageMem nvg
(ImagePremultiplied) (toStrict $ encodePng cr))
ImagePremultiplied (toStrict $ encodePng cr))
crs
imgs <- if any isNothing mresimgs
then do
logIO Error ("failed to load: " ++ fp ++ " " ++ show id)
logIO Error ("failed to load: " ++ fp ++ " " ++ show i)
exitFailure
else
return $ catMaybes mresimgs
return $
( id
( i
, Animation dur imgs pb
)
) idconfs