justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Cleanup warnings

Browse Source
This commit is contained in:
jgk
2021-05-17 22:39:18 +02:00
parent d7fcdbf550
commit 69f915a894
102 changed files with 1243 additions and 1185 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/LevelGen/AutoDoor.hs
+11 -9
View File
@@ -5,7 +5,7 @@ Creation of doors that open when creatures approach them.
module Dodge.LevelGen.AutoDoor
where
import Dodge.Data
import Dodge.Creature.State.Data
--import Dodge.Creature.State.Data
import Dodge.Base
import Dodge.SoundLogic
import Dodge.Creature.Property
@@ -13,11 +13,11 @@ import Geometry
import Picture
import qualified DoubleStack as DS
import Data.List
import Data.Maybe
--import Data.List
--import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.DeepSeq (deepseq)
--import Control.DeepSeq (deepseq)
addAutoDoor
:: Point2 -- ^ Left point
@@ -41,10 +41,11 @@ mkAutoDoor
-> Point2 -- ^ Right point (though the two points should be symmetric)
-> [Int] -- ^ Wall ids
-> [Wall]
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
xs
(lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
mkAutoDoor pl pr xs = addSound
$ zipWith3 (autoDoorPane (pl,pr))
xs
(lDoorClosed ++ rDoorClosed)
(map shiftL lDoorClosed ++ map shiftR rDoorClosed)
where
lDoorClosed = [ (pld,hwd)
, (hwd,hwu)
@@ -67,7 +68,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane (pl,pr))
shiftR = h $ (-.- parallel) . (+.+ normalizeV parallel)
h func (x,y) = (func x,func y)
addSound (x:xs) = f x : xs
addSound (x:ys) = f x : ys
addSound _ = error "Trying to add a sound to malformed auto door"
f wl = over doorMech g wl
g dm w
| dist wp pld > 2 && dist wp hwd > 2
src/Dodge/LevelGen/Block.hs
+19 -15
View File
@@ -1,6 +1,4 @@
{- |
Creation, update and destruction of destructible walls.
-}
{- | Creation, update and destruction of destructible walls. -}
module Dodge.LevelGen.Block where
import Dodge.Data
import Dodge.Base
@@ -13,6 +11,7 @@ import Picture.Data
import Control.Lens
import Control.Monad.State
import Data.List
import Data.Maybe
import Data.Function
import qualified Data.IntMap.Strict as IM
import System.Random
@@ -37,19 +36,21 @@ Plays destruction sound and sets to be displayed other walls that were shadowed
killBlock :: Wall -> World -> World
killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
where
f bl@Block{_blDegrades = (x:xs)} = degradeBlock bl . hitSound bl
f bl = hitSound' bl
f :: Wall -> World -> World
f bl'
| isJust (bl ^? blDegrades . ix 0) = degradeBlock bl' . breakHitSound bl
| otherwise = hitSound' bl'
pos = fst $ _wlLine bl
hitSound bl
| _wlIsSeeThrough bl = mkSoundBreakGlass pos
breakHitSound bl'
| _wlIsSeeThrough bl' = mkSoundBreakGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
hitSound' bl
| _wlIsSeeThrough bl = mkSoundSplinterGlass pos
hitSound' bl'
| _wlIsSeeThrough bl' = mkSoundSplinterGlass pos
| otherwise = soundMultiFrom sos soundid 25 0
sos = [BlockDegradeSound 0,BlockDegradeSound 1]
(soundid,_) = randomR (29,32) $ _randGen w
unshadow :: Int -> World -> World
unshadow bid w = case w ^? walls . ix bid of
unshadow bid w' = case w' ^? walls . ix bid of
Just b ->
let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
@@ -101,9 +102,9 @@ addBlock (p:ps) hp col isSeeThrough degradability w
& wallsZone %~ flip (IM.foldr wallInZone) panes
& walls %~ IM.union panes
where
lines = zip (p:ps) (ps ++ [p])
lns = zip (p:ps) (ps ++ [p])
i = newKey $ _walls w
is = [i.. i + length lines-1]
is = [i.. i + length lns-1]
panes = IM.fromList $ zip is $ zipWith
(\j (a,b) -> Block
{ _wlLine = (a,b)
@@ -117,7 +118,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
, _blShadows = []
, _blDegrades = degradability
}
) is lines
) is lns
wallInZone wl
| uncurry dist (_wlLine wl) <= 2*zoneSize
= insertIMInZone x y wlid wl
@@ -126,9 +127,12 @@ addBlock (p:ps) hp col isSeeThrough degradability w
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine wl)
wlid = _wlID wl
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
putBlock :: [Point2] -> Int -> Color -> Bool -> [Int] -> World -> World
putBlock (p:ps) i c b is w = foldr (uncurry removePathsCrossing) wWithBlock pairs
where pairs = zip (p:ps) (ps ++ [p])
wWithBlock = addBlock (p:ps) i c b is w
where
pairs = zip (p:ps) (ps ++ [p])
wWithBlock = addBlock (p:ps) i c b is w
putBlock _ _ _ _ _ _ = error "Trying to put a block with incomplete polygon"
src/Dodge/LevelGen/InnerWalls.hs
+5 -7
View File
@@ -1,13 +1,11 @@
module Dodge.LevelGen.InnerWalls
where
import Dodge.Data
import Dodge.Base
import Geometry
import Control.Lens
import qualified Data.IntMap as IM
--import Dodge.Data
--import Dodge.Base
--import Geometry
--import Control.Lens
--import qualified Data.IntMap as IM
------------------------------------------------------------------------------------
-- idea: create inner walls to draw and to cast shadows
--createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall
src/Dodge/LevelGen/LineBlock.hs
+9 -12
View File
@@ -6,14 +6,11 @@ module Dodge.LevelGen.LineBlock
import Dodge.Data
import Dodge.Base
import Dodge.LevelGen.Pathing
import Picture
--import Picture
import Geometry
import Control.Lens
import qualified Data.IntMap as IM
-- | Taken from online, splits a list into its even and odd elements
evenOddSplit = foldr f ([],[])
where f a (ls,rs) = (rs, a : ls)
putLineBlock
:: Wall -- ^ Base pane
@@ -39,7 +36,7 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
,( halfBlockWidth,-depth)
]
cornersAt p = fmap ( (p +.+) . rotateV rot) cornerPoints
linesAt p = map (\(a,b) -> (a,b)) $ makeLoopPairs $ cornersAt p
linesAt p = makeLoopPairs $ cornersAt p
k = newKey $ _walls w
ksAtI i = map ( + (k + i*4) ) [0,1,2,3]
visibilityAt i
@@ -52,13 +49,13 @@ putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr i
| otherwise = ksAtI (i-1) ++ ksAtI (i+1)
makeBlockAt :: Point2 -> Int -> [Wall]
makeBlockAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p)
makePane i visStatus k' ps
= basePane {_wlID = k'
,_wlLine = ps
,_blIDs = ksAtI i
,_blShadows = shadowsAt i
,_blVisible = visStatus
}
makePane i visStatus k' ps = basePane
{_wlID = k'
,_wlLine = ps
,_blIDs = ksAtI i
,_blShadows = shadowsAt i
,_blVisible = visStatus
}
listBlocks = concat $ zipWith makeBlockAt blockCenPs is
insertBlock :: Wall -> World -> World
insertBlock wl = over walls $ IM.insert (_wlID wl) wl
src/Dodge/LevelGen/Pathing.hs
+9 -11
View File
@@ -1,28 +1,26 @@
module Dodge.LevelGen.Pathing
where
import Dodge.Data
import Dodge.Base
import Geometry
import Control.Lens
import Dodge.Data
import Dodge.Base
import Data.Maybe
import Data.List
import qualified Data.IntMap as IM
import Data.Graph.Inductive hiding ((&))
import Data.Graph.Inductive.NodeMap
--import Data.Graph.Inductive.NodeMap
pairsToGraph :: (Ord a, Eq a, Eq b) => (a -> a -> b) -> [(a,a)] -> Gr a b
pairsToGraph f pairs = let nodes = nub (map fst pairs ++ map snd pairs)
pairs' = map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes >> insMapEdgesM pairs'
pairsToGraph f pairs =
let nodes' = nub (map fst pairs ++ map snd pairs)
pairs' = map (\(x,y)->(x,y,f x y)) pairs
in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM nodes' >> insMapEdgesM pairs'
removePathsCrossing :: Point2 -> Point2 -> World -> World
removePathsCrossing a b w = set pathGraph newGraph $ set pathGraph' pg'
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
$ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
w
where
pg' = filter (isNothing . uncurry (intersectSegSeg' a b)) $ _pathGraph' w
insertPoint pp@(_,(x,y)) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
src/Dodge/LevelGen/StaticWalls.hs
+24 -23
View File
@@ -5,17 +5,16 @@ Description : Concerns carving out of static walls to create the general room pl
module Dodge.LevelGen.StaticWalls
where
import Dodge.Data
import Dodge.Base
import Dodge.Default
--import Dodge.Base
--import Dodge.Default
import Geometry
import Control.Lens
--import Control.Lens
import Data.Function (on)
import Data.Graph
import Data.List
import Data.Maybe
import qualified Data.IntMap as IM
import qualified Data.Set as S
--import qualified Data.IntMap as IM
--import qualified Data.Set as S
-- | Describe a wall as two points.
-- Order is important: the wall face is to the left as you move from 'fst'
-- to 'snd'.
@@ -48,7 +47,6 @@ cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
_ -> cutWalls (map (rotateV 0.001) $ expandPolyBy 0.01 ps) wls
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-- | As 'cutWalls', but rotate in the other direction.
cutWallsL :: [Point2] -> [WallP] -> [WallP]
cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
@@ -58,7 +56,6 @@ cutWallsL ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
_ -> cutWalls (map (rotateV (-0.001)) $ expandPolyBy 0.01 ps) wls
where
newWalls = cutWalls' ps wls
errsL = mapMaybe (`checkWallLeft` newWalls) newWalls
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- Give error if created walls are not consistent.
@@ -87,8 +84,8 @@ checkWallRight (x,y) wls
| length ins == length outs = Nothing
| otherwise = Just ((x,y), outs)
where
ins = filter (\(a,b) -> b == y) wls
outs = filter (\(a,b) -> a == y) wls
ins = filter (\(_,b) -> b == y) wls
outs = filter (\(a,_) -> a == y) wls
-- | Given a specific wall and list of walls, checks that the number of walls leaving the
-- first point is the same as the number of walls entering the first point of
-- the specific wall.
@@ -99,8 +96,8 @@ checkWallLeft (x,y) wls
| length ins == length outs = Nothing
| otherwise = Just ((x,y), outs)
where
ins = filter (\(a,b) -> a == x) wls
outs = filter (\(a,b) -> b == x) wls
ins = filter (\(a,_) -> a == x) wls
outs = filter (\(_,b) -> b == x) wls
-- | Given a polygon of points and collection of walls, cuts out the polygon.
-- Ie returns a new set of walls with a hole determined by anticlockwise ordering of the points.
-- The overall procedure is:
@@ -113,7 +110,7 @@ checkWallLeft (x,y) wls
-- 6. remove any duplicate walls
-- Unclear behaviour if a line in the polygon is colinear with a wall.
cutWalls' :: [Point2] -> [WallP] -> [WallP]
cutWalls' qs walls =
cutWalls' qs wls =
nub
. filter (not.wallIsZeroLength)
. fuseWallsWith zs
@@ -124,7 +121,7 @@ cutWalls' qs walls =
$ removeWallsInPolygon ps
cwals
where
(zs,cwals) = cutWallsWithPoints ps walls
(zs,cwals) = cutWallsWithPoints ps wls
ps = orderPolygon qs
rs = orderPolygon $ nub $ zs ++ qs
-- | Given a value and a poly, pushes the poly points out from the center by the
@@ -145,6 +142,7 @@ cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p]))
( nub $ as ++ cutWallsPoints p1 p2 ws'
, concatMap (cutWall p1 p2) ws'
)
cutWallsWithPoints _ _ = error "Trying to cut empty polygon"
-- | List the points of intersection between a segment and collection of walls.
cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2]
--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y)
@@ -154,11 +152,13 @@ cutWall :: Point2 -> Point2 -> WallP -> [WallP]
cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of
Nothing -> [(x,y)]
Just cp -> [(x,cp),(cp,y)]
-- | Add poly walls?
addPolyWalls
:: [Point2] -- ^ Multiple walls described as a polygon.
-> [WallP]
-> [WallP]
addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
addPolyWalls (q:qs) wls = foldr addPolyWall wls (zip (q:qs) (qs++[q]))
addPolyWalls _ _ = error "Trying to add empty poly walls"
-- | Add a new wall to a list of walls only if either
-- 1. no wall already exists on the normal line from the new wall
-- 2. any of the first existing walls hit on the normal line from the new wall
@@ -166,12 +166,12 @@ addPolyWalls (q:qs) walls = foldr addPolyWall walls (zip (q:qs) (qs++[q]))
-- The normal line is the line from the center point of the new wall outwards
-- along the clockwise normal of the new wall (currently 10000 units along)
addPolyWall :: WallP -> [WallP] -> [WallP]
addPolyWall (p1,p2) walls =
addPolyWall (p1,p2) wls =
case maybeWs of
Just ws -> if all (\(x,y) -> isLHS x y p3) ws
then walls
else (p1,p2) : walls
Nothing -> (p1,p2) : walls
then wls
else (p1,p2) : wls
Nothing -> (p1,p2) : wls
where
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
@@ -182,10 +182,10 @@ addPolyWall (p1,p2) walls =
wlsP :: [(WallP, Point2)]
wlsP = sortBy (compare `on` (dist p3 . snd))
. catMaybes
$ zipWith f walls maybes
$ zipWith f wls maybes
f a (Just b) = Just (a,b)
f _ Nothing = Nothing
maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls
maybes = map (uncurry $ myIntersectSegSeg p3 p4) wls
-- | Given a list of points and a point, returns a point in the list if any is close
-- to the point.
findClosePoint :: [Point2] -> Point2 -> Maybe Point2
@@ -212,10 +212,11 @@ fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') )
fuseWallsWith :: [Point2] -> [WallP] -> [WallP]
fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws
where
fuseWalls' w (ps, ws) =
fuseWalls' w (ps, ws') =
let (qs, w') = fuseWall (ps, w)
in (qs, w' : ws)
in (qs, w' : ws')
-- | Test if fst p == snd p.
wallIsZeroLength :: Eq a => (a,a) -> Bool
wallIsZeroLength (x,y) = x == y
-- | Given a polygon and list of walls, removes walls inside the polygon.
removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP]
src/Dodge/LevelGen/Switch.hs
+2
View File
@@ -50,6 +50,7 @@ makeSwitch c effOn effOff = Button
switchEffect b = case _btState b of
BtOff -> effOn . over buttons (IM.adjust turnOn (_btID b))
BtOn -> effOff . over buttons (IM.adjust turnOff (_btID b))
_ -> error "Trying to switch a button with no label"
offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
polygon $ rectNSEW (-2) (-5) (-10) 10
,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
@@ -70,3 +71,4 @@ makeSwitch c effOn effOff = Button
, _btPict = offPict
, _btText = "SWITCH/"
}
src/Dodge/LevelGen/TriggerDoor.hs
+4 -5
View File
@@ -14,9 +14,7 @@ import Data.List
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import Control.Lens
import Control.DeepSeq (deepseq)
import Data.Graph.Inductive hiding ((&))
import Data.Graph.Inductive.NodeMap
-- probably don't have to rebuild the entire graph, oh well
addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> World -> World
@@ -27,7 +25,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtNoLabel == _btState (_buttons w IM.! bid)
cond w' = BtNoLabel == _btState (_buttons w' IM.! bid)
bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
@@ -45,7 +43,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
$ putDoubleDoor c cond a b w
where
bid = newKey $ _buttons w
cond w = BtOn == _btState (_buttons w IM.! bid)
cond w' = BtOn == _btState (_buttons w' IM.! bid)
bt = (makeSwitch c openDoor closeDoor) {_btPos = btp, _btRot = btr, _btID = bid}
(newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg' a b))
$ _pathGraph' w
@@ -127,7 +125,8 @@ mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
addSound (x:xs) = f x : xs
addSound (x:ys) = f x : ys
addSound _ = error "When creating a trigger door, added a sound to nothing"
f wl = over doorMech g wl
g dm w
| dist wp pld > 2 && dist wp hwd > 2