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

Some linting

Browse Source
This commit is contained in:
jgk
2021-08-10 14:22:33 +02:00
parent 51b8fab214
commit e43488ee17
11 changed files with 65 additions and 95 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Procedural.hs
+8 -8
View File
@@ -226,7 +226,7 @@ randomFourCornerRoom = do
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((V2 0 0),a) r) corners [0,pi/2,pi,3*pi/2]
$ zipWith (\r a -> shiftRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2]
)
{- | Creates room with a central vault with doors around it.
-}
@@ -246,10 +246,10 @@ centerVaultRoom n w h d = do
return $ defaultRoom
{ _rmPolys = polys
, _rmLinks =
[((V2 0 h),0)
,((V2 w 0),-pi/2)
,((V2 (-w) (0)),pi/2)
,((V2 (0) (-h)),pi)
[(V2 0 h , 0 )
,(V2 w 0 ,-pi/2)
,(V2 (-w) 0 , pi/2)
,(V2 0 (-h), pi )
]
, _rmPath = []
, _rmPS =
@@ -259,15 +259,15 @@ centerVaultRoom n w h d = do
,sPS (V2 (5-w) (h-5)) 0 putLamp
,sPS (V2 (5-w) (5-h)) 0 putLamp
]
++ concat (zipWith (\i r -> map (shiftPSBy ((V2 0 0),r)) $ theDoor i)
++ concat (zipWith (\i r -> map (shiftPSBy (V2 0 0,r)) $ theDoor i)
[n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
, _rmBound = [rectNSWE h (-h) (-w) w]
}
where
col = dim $ dim $ bright red
theDoor i =
[ sPS (V2 (0) (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) (0)) (V2 19 0)
, sPS (V2 (35) (d+4)) 0 $ PutButton $ makeSwitch col
[ sPS (V2 0 (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) 0) (V2 19 0)
, sPS (V2 35 (d+4)) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
]
src/Dodge/Room/RoadBlock.hs
+10 -10
View File
@@ -32,20 +32,20 @@ litCorridor90 = do
poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom
{ _rmPolys = [poly,poly2]
, _rmLinks = [ ((V2 (40) (h - 80)), -pi/2)
, ((V2 (20) ( 0)), pi)
, _rmLinks = [ (V2 40 (h - 80), -pi/2)
, (V2 20 0 , pi )
]
, _rmPath = concatMap doublePair
[((V2 20 0),(V2 (20) (h-40)))
,((V2 ( 0) (h-40)),(V2 (20) (h-40)))
,((V2 (40) (h-40)),(V2 (20) (h-40)))
[( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) )
,( V2 40 (h-40) , V2 20 (h-40) )
]
, _rmPS =
[ sPS (V2 (20) (h-5)) 0 putLamp
, windowLine (V2 (0) (h-20)) (V2 (40) (h-20))
[ sPS (V2 20 (h-5)) 0 putLamp
, windowLine (V2 0 (h-20)) (V2 40 (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
, sPS (V2 ( 20) (h-40)) 0 $ PutID 0
, sPS (V2 20 (h-40)) 0 $ PutID 0
, sPS (V2 (-20) (h-80)) 0 $ PutID 2
]
, _rmBound = [poly]
@@ -60,7 +60,7 @@ longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
longBlockedCorridor = do
r <- state $ randomR (0,pi)
n <- state $ randomR (0,3)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) (75/256) (0) (250/256))
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) (75/256) 0 (250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (V2 20 15) 0 putLamp
]
@@ -71,7 +71,7 @@ longBlockedCorridor = do
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do
r <- state $ randomR (0,pi)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) ( 0) ( 250/256))
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) 0 ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (V2 20 15) 0 putLamp
]
src/Dodge/Room/Start.hs
+5 -5
View File
@@ -16,20 +16,20 @@ import Control.Lens
import System.Random
rezBox :: Room
rezBox = shiftRoomBy ((V2 (-20) (-10)),0) $ roomRect 40 20 1 1 & rmPS .~ []
rezBox = shiftRoomBy (V2 (-20) (-10),0) $ roomRect 40 20 1 1 & rmPS .~ []
startRoom :: RandomGen g => State g (Tree (Either Room Room))
startRoom = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
let fground = sPS (V2 0 0) 0 $ PutForeground $
highPipe 80 (V2 (0) (h/3)) (V2 (w) ( h/2))
++ highPipe 40 (V2 (0) (h/2)) (V2 (w) ( h/3))
++ highPipe 60 (V2 (w/3) (0)) (V2 (w/3) ( h))
highPipe 80 (V2 0 (h/3)) (V2 w (h/2))
++ highPipe 40 (V2 0 (h/2)) (V2 w (h/3))
++ highPipe 60 (V2 (w/3) 0 ) (V2 (w/3) h )
-- ++ highPipe 20 (0,2*h/3) (w, h/3)
-- , girderV cola 10 (0,3*h/4) (w, 3*h/4)
-- , girder colb 5 (0,5*h/8) (w, 5*h/8)
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((V2 (-20) (-20)),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy (V2 (-20) (-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
-- where
-- cola = dark . dark . light . light $ light red
-- colb = dark . dark . light . light $ light blue
src/Dodge/Room/Teleport.hs
+1 -1
View File
@@ -34,7 +34,7 @@ telRoomLev i = do
where
telPP = PressPlate
{ _ppPict = setDepth 0.5 . color red $ polygon ppFootprint
, _ppPos = (V2 0 0)
, _ppPos = V2 0 0
, _ppRot = 0
, _ppEvent = levelReset
, _ppID = 0
src/Dodge/Room/Treasure.hs
+9 -9
View File
@@ -25,17 +25,17 @@ triLootRoom
triLootRoom w h = pure $ defaultRoom
{ _rmPolys = [ tri
, base
]
, _rmLinks = [((V2 (0) (-80)),pi)]
, _rmPath = doublePair ((V2 (0) (-80)),(V2 (0) (h/2)))
]
, _rmLinks = [(V2 0 (-80) , pi)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPS =
[sPS (V2 (15-w) ( 15)) 0 $ PutID 0
,sPS (V2 (w-15) ( 15)) pi $ PutID 0
,sPS (V2 ( 0) (h-35)) 0 $ PutID 2
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0
,sPS (V2 0 (h-35)) 0 $ PutID 2
,sPS (V2 ( -5) (h-10)) 0 putLamp
,sPS (V2 ( 5) (h-10)) 0 putLamp
,sPS (V2 ( 0) (h-15)) 0 putLamp
,sPS (V2 ( 0) ( -60)) 0 putLamp
,sPS (V2 5 (h-10)) 0 putLamp
,sPS (V2 0 (h-15)) 0 putLamp
,sPS (V2 0 ( -60)) 0 putLamp
]
, _rmBound = [tri , base]
}
src/Dodge/Update/Camera.hs
+6 -6
View File
@@ -158,18 +158,18 @@ farWallDist :: Point2 -> World -> Float
{-# INLINE farWallDist #-}
farWallDist cpos w = min (halfWidth w / (horizontalMax+50) ) (halfHeight w / (verticalMax+50) )
where
horizontalMax = maximum $ map (h' (V2 1 0)) rRays ++ map (h' (V2 (-1) (0))) lRays
verticalMax = maximum $ map (h' (V2 0 1)) tRays ++ map (h' (V2 (0) (-1))) bRays
horizontalMax = maximum $ map (h' (V2 1 0)) rRays ++ map (h' (V2 (-1) 0) ) lRays
verticalMax = maximum $ map (h' (V2 0 1)) tRays ++ map (h' (V2 0 (-1))) bRays
--h p = fromMaybe p $ collidePointIndirect cpos p $ wallsAlongLine cpos p w
--h p = fromMaybe p . collidePointIndirect cpos p $ _walls w
wos = wallsOnScreen w
h p = fromMaybe p $ collidePointIndirect cpos p wos
h' x p = dotV (rotateV camRot x) (p -.- cpos)
camRot = _cameraRot w
rRays = rotF [(V2 ( maxViewDistance) (y)) | y <- zs]
lRays = rotF [(V2 (-maxViewDistance) (y)) | y <- zs]
tRays = rotF [(V2 (y) ( maxViewDistance)) | y <- zs]
bRays = rotF [(V2 (y) (-maxViewDistance)) | y <- zs]
rRays = rotF [V2 maxViewDistance y | y <- zs]
lRays = rotF [V2 (-maxViewDistance) y | y <- zs]
tRays = rotF [V2 y maxViewDistance | y <- zs]
bRays = rotF [V2 y (-maxViewDistance) | y <- zs]
rotF = map (h . (+.+) cpos . rotateV (_cameraRot w))
zs = takeWhile (< maxViewDistance) [-maxViewDistance,negate $ 0.75*maxViewDistance..]
maxViewDistance = 800
src/Dodge/WorldEvent/Cloud.hs
+1 -1
View File
@@ -14,7 +14,7 @@ makeCloudAt rad t drawFunc p w = w & clouds %~ (theCloud :)
where
theCloud = Cloud
{ _clPos = p
, _clVel = (V2 0 0)
, _clVel = V2 0 0
, _clPict = drawFunc
, _clRad = rad
, _clTimer = t
src/Dodge/WorldEvent/SpawnParticle.hs
+4 -4
View File
@@ -59,9 +59,9 @@ drawFlame rotd pt = thePic
ep = _btPos' pt
thePic = pictures
[ glow
, aPic 3 prot2 18 (V2 (scaleChange + 1) (2)) red
, aPic 4 prot 19 (V2 (scaleChange + 0.5) (1.5)) orange
, aPic 5 prot3 20 (V2 (scaleChange) (1)) white
, aPic 3 prot2 18 (V2 (scaleChange + 1) 2 ) red
, aPic 4 prot 19 (V2 (scaleChange + 0.5) 1.5) orange
, aPic 5 prot3 20 (V2 (scaleChange) 1 ) white
]
aPic :: Int -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture
aPic lay offset depth (V2 scalex scaley) col
@@ -143,7 +143,7 @@ makeFlameletTimed (V2 x y) z vel maycid size time w = w
, _ptUpdate' = moveFlamelet
, _btVel' = vel
, _btColor' = red
, _btPos' = (V2 x y)
, _btPos' = V2 x y
, _btPassThrough' = maycid
, _btWidth' = size
, _btTimer' = time
src/Geometry/Intersect.hs
+5 -5
View File
@@ -1,4 +1,4 @@
{-# LANGUAGE TupleSections #-}
--{-# LANGUAGE TupleSections #-}
{-
Testing for and finding intersection points.
-}
@@ -100,12 +100,12 @@ myIntersectSegSeg a@(V2 ax ay) b@(V2 bx by) c@(V2 cx cy) d@(V2 dx dy) = case rat
-- | Polymorphic intersection of fractional line points.
myIntersectLineLine :: (Eq a,Fractional a) => V2 a -> V2 a -> V2 a -> V2 a -> Maybe (V2 a)
myIntersectLineLine a@(V2 ax _) b c@(V2 cx _) d
| isNothing (linGrad a b) = (V2 ax) <$> axisInt (c *-* (V2 ax 0)) (d *-* (V2 ax 0))
| isNothing (linGrad c d) = (V2 cx) <$> axisInt (a *-* (V2 cx 0)) (b *-* (V2 cx 0))
| isNothing (linGrad a b) = V2 ax <$> axisInt (c *-* V2 ax 0) (d *-* V2 ax 0)
| isNothing (linGrad c d) = V2 cx <$> axisInt (a *-* V2 cx 0) (b *-* V2 cx 0)
| otherwise
= case linGrad a b ^-^ linGrad c d of
Just 0 -> Nothing
_ -> liftA2 (V2) newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
_ -> liftA2 V2 newx ((linGrad a b ^*^ newx) ^+^ axisInt a b)
where
(^-^) = liftA2 (-)
(^+^) = liftA2 (+)
@@ -142,7 +142,7 @@ linGrad (V2 x y) (V2 a b)
| otherwise = Just $ (y-b)/(x-a)
-- | Given two points, finds the intersection with the y axis if it exists.
axisInt :: (Eq a,Fractional a) => V2 a -> V2 a -> Maybe a
axisInt p (V2 a b) = fmap (\lg -> b - (a*lg)) $ linGrad p (V2 a b)
axisInt p (V2 a b) = (\lg -> b - (a*lg)) <$> linGrad p (V2 a b)
-- | Placeholder, undefined.
intersectSegsSeg :: [Point2] -> Point2 -> Point2 -> Maybe Point2
intersectSegsSeg = undefined
src/Polyhedra/Data.hs
+2 -2
View File
@@ -10,7 +10,7 @@ import qualified Data.Map as M
-- | Polyhedra are represented as a list of faces.
-- Each face is a list of points (and colours) that are assumed to lie on a plane, and be
-- ordered to form an anticlockwise convex polygon within that plane.
data Polyhedra = Polyhedron
newtype Polyhedra = Polyhedron
{ _pyFaces :: [[(Point3,Point4)]]
}
@@ -19,7 +19,7 @@ data Polyhedra = Polyhedron
-- The vertices of the faces are assumed to start with a point adjacent to the
-- key vertex and to be listed anticlockwise around the center of the face.
-- The key vertex is not included in the list.
data VF a = VF
newtype VF a = VF
{ _vertices :: M.Map a (Point3, [[a]])
}
src/Shader/Poke.hs
+14 -44
View File
@@ -1,6 +1,5 @@
{-# LANGUAGE TupleSections
, BangPatterns
#-}
--{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-}
module Shader.Poke
( pokeArrayOff
, pokePoint3s
@@ -30,7 +29,7 @@ import Control.Monad.Primitive
pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
pokeVerxs vbos vxs = do
count <- MV.replicate 6 0
SP.mapM_ (\vx -> pokeVerx vbos count vx >> addCountVerx count vx) $ SP.each vxs
SP.mapM_ (pokeVerx vbos count) $ SP.each vxs
vToPicShad count
-- F.foldM (F.FoldM
-- (\_ vx -> pokeVerx vbos count vx >> addCountVerx count vx)
@@ -40,6 +39,7 @@ pokeVerxs vbos vxs = do
-- vxs
vToPicShad :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
{-# INLINE vToPicShad #-}
vToPicShad mv = mapM (MV.unsafeRead mv) $ PicShads 0 1 2 3 4 5
pokeVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
@@ -49,35 +49,9 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
let thePtr = plusPtr (_vboPtr $ vboFromType vbos sn) (typeOff * pokeStride sn * floatSize)
poke34 thePtr thePos theCol
pokeArrayOff thePtr 7 ext
MV.unsafeModify offsets (+1) sn
where
sn = _unShadNum theShadNum
-- case _unShadNum theShadNum of
-- 0 -> do
-- typeOff <- MV.unsafeRead offsets 0
-- poke34 (plusPtr (_vboPtr $ vboFromType vbos 0) (typeOff * 7 * floatSize)) thePos theCol
-- 1 -> do
-- typeOff <- MV.unsafeRead offsets 1
-- let thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (typeOff * 8 * floatSize)
-- poke34 thePtr thePos theCol
-- pokeArrayOff thePtr 7 ext
-- 2 -> do
-- typeOff <- MV.unsafeRead offsets 2
-- let thePtr = plusPtr (_vboPtr $ _psBez vbos) (typeOff * 11 * floatSize)
-- poke34 thePtr thePos theCol
-- pokeArrayOff thePtr 7 ext
-- 3 -> do
-- typeOff <- MV.unsafeRead offsets 3
-- let thePtr = plusPtr (_vboPtr $ _psText vbos) (typeOff * 9 * floatSize)
-- poke34 thePtr thePos theCol
-- pokeArrayOff thePtr 7 ext
-- 4 -> do
-- typeOff <- MV.unsafeRead offsets 4
-- let thePtr = plusPtr (_vboPtr $ _psArc vbos) (typeOff * 10 * floatSize)
-- poke34 thePtr thePos theCol
-- pokeArrayOff thePtr 7 ext
-- 5 -> do
-- typeOff <- MV.unsafeRead offsets 5
-- poke34 (plusPtr (_vboPtr $ _psEll vbos) (typeOff * 7 * floatSize)) thePos theCol
poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
{-# INLINE poke34 #-}
@@ -90,19 +64,15 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do
pokeElemOff ptr 5 f
pokeElemOff ptr 6 g
addCountVerx :: MV.MVector (PrimState IO) Int -> Verx -> IO ()
{-# INLINE addCountVerx #-}
addCountVerx vec vx = MV.unsafeModify vec (+1) (_unShadNum $ _vxShadNum vx)
pokeArrayOff :: Ptr Float -> Int -> [Float] -> IO ()
--{-# INLINE pokeArrayOff #-}
{-# INLINE pokeArrayOff #-}
pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))
pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
pokePoint33s ptr vals0 = go vals0 0
where
go [] n = return n
go ( !(!(V3 a b c),!(V3 d e f)):vals) !n = do
go ( !(V3 a b c,V3 d e f):vals) !n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
@@ -117,7 +87,7 @@ pokePoint3s :: Ptr Float -> [Point3] -> IO Int
pokePoint3s ptr vals0 = go vals0 0
where
go [] n = return n
go ( !(V3 a b c):vals) !n = do
go ( V3 a b c:vals) !n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c
@@ -125,10 +95,9 @@ pokePoint3s ptr vals0 = go vals0 0
where
off i = n*3 + i
--comLayVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> () -> Verx -> IO (MV.MVector (PrimState IO) Int)
comLayVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
--{-# INLINE comLayVerx #-}
comLayVerx vbos counts vx = do
pokeLayVerx :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
--{-# INLINE pokeLayVerx #-}
pokeLayVerx vbos counts vx = do
theOff <- MV.unsafeRead counts vecPos
let thePtr = plusPtr basePtr ((theOff + layOff) * theStride * floatSize)
poke34 thePtr thePos theCol
@@ -159,10 +128,11 @@ vboFromType ps sn = case sn of
pokeLayVerxs :: PicShads VBO -> [Verx] -> IO (IM.IntMap (PicShads Int))
pokeLayVerxs vbos vxs = do
counts <- MV.replicate (6*6) 0
SP.mapM_ (comLayVerx vbos counts) $ SP.each vxs
SP.mapM_ (pokeLayVerx vbos counts) $ SP.each vxs
vToLayPicShad counts
vToLayPicShad :: MV.MVector RealWorld Int -> IO (IM.IntMap (PicShads Int))
{-# INLINE vToLayPicShad #-}
vToLayPicShad mv = foldM f IM.empty [0..5]
where
f m i = fmap (\ps -> IM.insert i ps m) (vToPicShad $ MV.unsafeSlice (i * 6) 6 mv)
@@ -181,7 +151,7 @@ poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
poke224s ptr vals0 = go vals0 0
where
go [] n = return n
go ((((V2 a b),(V2 c d)),(V4 e f g h)):vals) !n = do
go (((V2 a b,V2 c d),V4 e f g h):vals) !n = do
pokeElemOff ptr (off 0) a
pokeElemOff ptr (off 1) b
pokeElemOff ptr (off 2) c