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

Cleanup

Browse Source
This commit is contained in:
justin
2022-02-13 17:29:32 +00:00
parent eba1713895
commit 40f1d987cb
21 changed files with 109 additions and 171 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+55 -64
View File
@@ -6,8 +6,7 @@ Consider splitting. -}
module Dodge.Base module Dodge.Base
( module Dodge.Base ( module Dodge.Base
, module Dodge.Base.You , module Dodge.Base.You
) ) where
where
import Dodge.Data import Dodge.Data
import Dodge.WinScale import Dodge.WinScale
import Dodge.Zone import Dodge.Zone
@@ -34,9 +33,8 @@ import Data.Maybe
takeUntil :: Foldable t => (a -> Bool) -> t a -> [a] takeUntil :: Foldable t => (a -> Bool) -> t a -> [a]
takeUntil p = foldr (\x xs -> x : if p x then [] else xs) [] takeUntil p = foldr (\x xs -> x : if p x then [] else xs) []
decreaseToZero :: Int -> Int decreaseToZero :: Int -> Int
decreaseToZero x = max 0 (x - 1) decreaseToZero = max 0 . subtract 1
decreaseToNothing' :: (Num a, Ord a) => Maybe' a -> Maybe' a decreaseToNothing' :: (Num a, Ord a) => Maybe' a -> Maybe' a
decreaseToNothing' ma = case ma of decreaseToNothing' ma = case ma of
@@ -54,7 +52,6 @@ errorHead s [] = error s
aCrPos :: Int -> World -> Point2 aCrPos :: Int -> World -> Point2
aCrPos i w = _crPos $ _creatures w IM.! i aCrPos i w = _crPos $ _creatures w IM.! i
selectedObject :: World -> Maybe (Either FloorItem Button) selectedObject :: World -> Maybe (Either FloorItem Button)
selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w
where where
@@ -75,15 +72,16 @@ yourItemRef
yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w))
wallNormal :: Wall -> Point2 wallNormal :: Wall -> Point2
wallNormal wl = normalizeV . vNormal $ a -.- b wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
where
(a,b) = _wlLine wl
wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> [Wall] wallsOnLine :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
wallsOnLine p1 p2 ws = hitWalls wallsOnLine p1 p2 = IM.filter
where (isJust . uncurry (intersectSegSeg p1 p2) . _wlLine)
hitPoint = uncurry (intersectSegSeg p1 p2) . _wlLine
hitWalls = filter (isJust . hitPoint) (IM.elems ws) wallsOnLineHit :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap (Point2, Wall)
wallsOnLineHit p1 p2 = IM.mapMaybe f
where
f wl = uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> (, wl)
wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall] wallsOnLine3D :: Point3 -> Point3 -> IM.IntMap Wall -> [Wall]
wallsOnLine3D = undefined wallsOnLine3D = undefined
@@ -97,10 +95,11 @@ wallsOnCirc p r = IM.filter f
f wl = uncurry circOnSeg (_wlLine wl) p r f wl = uncurry circOnSeg (_wlLine wl) p r
allWalls :: World -> IM.IntMap Wall allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _znObjects $ _wallsZone w allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
creaturesNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] creaturesNearPoint p w = IM.unions
[f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where where
(x,y) = crZoneOfPoint p (x,y) = crZoneOfPoint p
f i m = case IM.lookup i m of f i m = case IM.lookup i m of
@@ -108,7 +107,8 @@ creaturesNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w |
_ -> IM.empty _ -> IM.empty
creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature
creaturesNearPointI n p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]] creaturesNearPointI n p w = IM.unions
[f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
where where
(x,y) = crZoneOfPoint p (x,y) = crZoneOfPoint p
f i m = case IM.lookup i m of f i m = case IM.lookup i m of
@@ -120,11 +120,14 @@ creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b] --creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
-- where f i m = case IM.lookup i m of Just val -> val -- where f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty -- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty kps
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s)) creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
kps = zoneOfLineIntMap a b where
f i m = case IM.lookup i m of Just val -> val g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
_ -> IM.empty f i = fromMaybe IM.empty . IM.lookup i
-- f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
{- | Expands a line out to a given thickness. -} {- | Expands a line out to a given thickness. -}
lineGeom :: Float -> Point2 -> Point2 -> [Point2] lineGeom :: Float -> Point2 -> Point2 -> [Point2]
lineGeom t x y lineGeom t x y
@@ -191,13 +194,6 @@ newProjectileKey = IM.newKey . _props
{- | Finds unused creature key. -} {- | Finds unused creature key. -}
newCrKey :: World -> Int newCrKey :: World -> Int
newCrKey = IM.newKey . _creatures newCrKey = IM.newKey . _creatures
-- | collides a point with forcefields
-- if found, returns point of collision, deflection if required, and the id
collidePointFFs :: a
collidePointFFs = undefined
collidePointFF :: a
collidePointFF = undefined
--
-- | Looks for overlap of a circle with walls. -- | Looks for overlap of a circle with walls.
-- If found, gives wall -- If found, gives wall
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
@@ -249,9 +245,9 @@ collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Lef
-- | Looks for first collision of a circle with walls. -- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal. -- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2) collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls p1 p2 rad ws collideCircWalls p1 p2 rad
= safeMinimumOn (dist p1 . fst) = safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe . IM.mapMaybe
(( \(x:y:_) -> fmap (( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1)) ((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ normalizeV (vNormal (x -.- y))) . (+.+ normalizeV (vNormal (x -.- y)))
@@ -259,7 +255,7 @@ collideCircWalls p1 p2 rad ws
(intersectSegSeg p1 p2 x y) (intersectSegSeg p1 p2 x y)
) )
. shiftByRad . _wlLine . shiftByRad . _wlLine
) ws )
where where
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+) shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b) [a +.+ rad *.* normalizeV (a -.-b)
@@ -284,22 +280,17 @@ collideCircWalls p1 p2 rad ws
-- | Looks for first collision of a point with walls. -- | Looks for first collision of a point with walls.
-- If found, gives point and wall. -- If found, gives point and wall.
collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall) collidePointWallsWall :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Wall)
collidePointWallsWall p1 p2 ws collidePointWallsWall p1 p2
= safeMinimumOn f = safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) ) . IM.mapMaybe ( \wl -> uncurry (intersectSegSeg p1 p2) (_wlLine wl) <&> ( , wl ) )
ws
where
f (a,_) = magV (p1 -.- a)
-- | Looks for first collision of a point with walls. -- | Looks for first collision of a point with walls.
-- If found, gives point and normal of wall. -- If found, gives point and normal of wall.
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2) collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws collidePointWallsNorm p1 p2 ws
= safeMinimumOn f = safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) ) $ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws . _wlLine) ws
where
f (a,_) = magV (p1 -.- a)
-- | Returns the first creature, if any, that a point intersects with. -- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
collidePointCreatures p1 p2 = fmap fst collidePointCreatures p1 p2 = fmap fst
@@ -339,53 +330,53 @@ collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
{- | Test if a circle collides with any wall. {- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -} - Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad w circOnSomeWall p rad
= any (\(x,y) -> circOnSeg x y p rad) = any (\(x,y) -> circOnSeg x y p rad)
. fmap _wlLine . fmap _wlLine
. IM.elems . IM.elems
$ wallsNearPoint p w . wallsNearPoint p
{- | Test whether there is a creature of weight 4 or greater near a line. -} {- | Test whether there is a creature of weight 4 or greater near a line. -}
isHeavyCrNearLine isHeavyCrNearLine
:: Float :: Float
-> [Point2] -> [Point2]
-> World -> World
-> Bool -> Bool
isHeavyCrNearLine d (p1:p2:_) w isHeavyCrNearLine d (p1:p2:_)
= any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c)) = any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
. IM.filter (\cr -> _crMass cr > 4) . IM.filter (\cr -> _crMass cr > 4)
$ _creatures w . _creatures
isHeavyCrNearLine _ _ _ = error "Testing whether creature is near empty line" isHeavyCrNearLine _ _ = error "Testing whether creature is near empty line"
{- | Adds the distance to the creature radius, tests whether the center is in {- | Adds the distance to the creature radius, tests whether the center is in
the circle of this size centered at the point -} the circle of this size centered at the point -}
crsNearPoint :: Float -> Point2 -> World -> Bool crsNearPoint :: Float -> Point2 -> World -> Bool
crsNearPoint d p w = any (\c -> dist (_crPos c) p < (d + _crRad c)) (_creatures w) crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
{- | Produce an unordered list of creatures on a line. -} {- | Produce an unordered list of creatures on a line. -}
crsOnLine :: Point2 -> Point2 -> World -> [Creature] crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnLine p1 p2 w crsOnLine p1 p2
= IM.elems = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr)) . _creatures
$ _creatures w
{- | Produce an unordered list of creatures on a wide line. -} {- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> [Creature] crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnThickLine thickness p1 p2 w crsOnThickLine thickness p1 p2
= IM.elems = IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
. IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness)) . _creatures
$ _creatures w
{- | Find 'Maybe' the closest creature to a point, within a circle. {- | Find 'Maybe' the closest creature to a point, within a circle.
-} -}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r w nearestCrInRad p r
= safeMinimumOn (dist p . _crPos) = safeMinimumOn (dist p . _crPos)
$ IM.filter (\cr -> dist p (_crPos cr) < r) $ _creatures w . IM.filter (\cr -> dist p (_crPos cr) < r)
. _creatures
{- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -} {- | Find 'Maybe' the closest creature in front of a point in a right-angle-triangle shape. -}
nearestCrInTri nearestCrInTri
:: Point2 :: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis). -> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance. -> Float -- ^ Distance.
-> World -> Maybe Creature -> World -> Maybe Creature
nearestCrInTri p dir x w nearestCrInTri p dir x
= safeMinimumOn (dist p . _crPos) = safeMinimumOn (dist p . _crPos)
$ IM.filter (\cr -> pointInPolygon (_crPos cr) tri) $ _creatures w . IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
. _creatures
where where
tri = tri =
[p [p
@@ -400,9 +391,10 @@ nearestCrInFront
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis). -> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance. -> Float -- ^ Distance.
-> World -> Maybe Creature -> World -> Maybe Creature
nearestCrInFront p dir x w nearestCrInFront p dir x
= safeMinimumOn (dist p . _crPos) = safeMinimumOn (dist p . _crPos)
$ IM.filter (\cr -> pointInPolygon (_crPos cr) rec) $ _creatures w . IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
. _creatures
where where
rec = [p, pR, pR1, pL1, pL ] rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0) pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
@@ -411,7 +403,7 @@ nearestCrInFront p dir x w
pL1 = pL +.+ rotateV dir (V2 (x/2) 0) pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
{- | Test whether a creature is in a polygon. -} {- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon cr = pointInPolygon (_crPos cr) crInPolygon = pointInPolygon . _crPos
{- | Transform coordinates from world position to screen coordinates. -} {- | Transform coordinates from world position to screen coordinates. -}
worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2 worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2
@@ -494,4 +486,3 @@ dbArg f x = f x x
-- TODO check whether this is simply the reader monad, flipped -- TODO check whether this is simply the reader monad, flipped
dbArgChain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b dbArgChain :: (a -> b -> b) -> (a -> b -> b) -> a -> b -> b
dbArgChain f g x = f x . g x dbArgChain f g x = f x . g x
src/Dodge/Block.hs
+1 -2
View File
@@ -21,8 +21,7 @@ splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardC
& blocks . ix (_blID bl) . blHPs %~ tail & blocks . ix (_blID bl) . blHPs %~ tail
& matSplintSound (_blMaterial bl) cen & matSplintSound (_blMaterial bl) cen
where where
wls = IM.restrictKeys (_walls w) (_blWallIDs bl) cen = centroid $ fst . _wlLine <$> IM.restrictKeys (_walls w) (_blWallIDs bl)
cen = centroid $ fmap (fst . _wlLine) wls
unshadowBlock :: Int -> World -> World unshadowBlock :: Int -> World -> World
unshadowBlock wlid w = case w ^? walls . ix wlid of unshadowBlock wlid w = case w ^? walls . ix wlid of
src/Dodge/Combine.hs
+2 -1
View File
@@ -23,7 +23,8 @@ import Data.Maybe
import Data.List (scanl',sortOn) import Data.List (scanl',sortOn)
combinationsTrie :: Trie (Int,CombineType) Item combinationsTrie :: Trie (Int,CombineType) Item
combinationsTrie = foldr (uncurry insertInTrie . first (sortOn snd)) combinationsTrie = foldr
(uncurry insertInTrie . first (sortOn snd))
emptyTrie emptyTrie
itemCombinations itemCombinations
src/Dodge/Debug.hs
+5 -14
View File
@@ -1,6 +1,5 @@
module Dodge.Debug where module Dodge.Debug where
import Dodge.Data import Dodge.Data
import Dodge.Picture
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Zone import Dodge.Zone
import Dodge.Base import Dodge.Base
@@ -14,17 +13,8 @@ import qualified Data.IntSet as IS
import Control.Lens import Control.Lens
drawCircleAtFor :: Point2 -> Int -> World -> World drawCircleAtFor :: Point2 -> Int -> World -> World
drawCircleAtFor p t w = w & props %~ drawCircleAtFor p t = drawCircleAtForCol p t white
IM.insert k Projectile
{ _pjPos = p
, _pjStartPos = p
, _pjVel = V2 0 0
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ uncurryV translate p $ color white $ circleSolid 20
, _pjID = k
, _pjUpdate = \_ -> pjTimerF t k
}
where
k = IM.newKey $ _props w
drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World drawCircleAtForCol :: Point2 -> Int -> Color -> World -> World
drawCircleAtForCol p t col w = w & props %~ drawCircleAtForCol p t col w = w & props %~
IM.insert k Projectile IM.insert k Projectile
@@ -37,13 +27,14 @@ drawCircleAtForCol p t col w = w & props %~
} }
where where
k = IM.newKey $ _props w k = IM.newKey $ _props w
drawLineForCol :: [Point2] -> Int -> Color -> World -> World drawLineForCol :: [Point2] -> Int -> Color -> World -> World
drawLineForCol ps t col w = w & props %~ drawLineForCol ps t col w = w & props %~
IM.insert k Projectile IM.insert k Projectile
{ _pjPos = head ps { _pjPos = head ps
, _pjStartPos = head ps , _pjStartPos = head ps
, _pjVel = V2 0 0 , _pjVel = V2 0 0
, _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ lineOfThickness 5 ps , _prDraw = \_ -> (,) mempty $ onLayer PtLayer $ color col $ thickLine 5 ps
, _pjID = k , _pjID = k
, _pjUpdate = \_ -> pjTimerF t k , _pjUpdate = \_ -> pjTimerF t k
} }
@@ -66,7 +57,7 @@ debugWallZoningPic :: World -> Picture
debugWallZoningPic w = setLayer 1 $ zonesPic `appendPic` wallsPic debugWallZoningPic w = setLayer 1 $ zonesPic `appendPic` wallsPic
where where
wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls wallsPic = setDepth 25 . color yellow . concatMapPic (drawTheWall . _wlLine) $ IM.elems theWalls
drawTheWall (a,b) = lineOfThickness 20 [a,b] drawTheWall (a,b) = thickLine 20 [a,b]
theWalls = wallsAlongLine sp ep w theWalls = wallsAlongLine sp ep w
zonesPic = setDepth 20 $ drawDDA zones zonesPic = setDepth 20 $ drawDDA zones
zones = ddaExt zoneSize sp ep zones = ddaExt zoneSize sp ep
src/Dodge/Event.hs
+6 -12
View File
@@ -39,12 +39,6 @@ import Control.Lens
import qualified Data.Set as S import qualified Data.Set as S
import SDL import SDL
--handleEvent :: Event -> Universe -> Maybe Universe
--handleEvent e uv = case handleEvent' e (_uvWorld uv) of
-- Nothing -> Nothing
-- Just w -> Just $ uv & uvWorld .~ w
handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent :: Event -> Universe -> IO (Maybe Universe)
handleEvent e = case eventPayload e of handleEvent e = case eventPayload e of
KeyboardEvent kev -> handleKeyboardEvent kev KeyboardEvent kev -> handleKeyboardEvent kev
@@ -64,18 +58,18 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
P (V2 x y) = mouseMotionEventPos mmev P (V2 x y) = mouseMotionEventPos mmev
handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
handleMouseButtonEvent mbev u = case mouseButtonEventMotion mbev of handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
Released -> Just $ u & updateButtons S.delete Released -> Just . updateButtons S.delete
Pressed -> handlePressedMouseButton thebutton $ u & updateButtons S.insert Pressed -> handlePressedMouseButton thebutton . updateButtons S.insert
where where
thebutton = mouseButtonEventButton mbev thebutton = mouseButtonEventButton mbev
updateButtons f = uvWorld . mouseButtons %~ f thebutton updateButtons f = uvWorld . mouseButtons %~ f thebutton
{- | Sets window position in config. -} {- | Sets window position in config. -}
handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe
handleWindowMoveEvent mev u = Just $ u handleWindowMoveEvent mev = Just
& config . windowPosX .~ fromIntegral x . (config . windowPosX .~ fromIntegral x)
& config . windowPosY .~ fromIntegral y . (config . windowPosY .~ fromIntegral y)
where where
P (V2 x y) = windowMovedEventPosition mev P (V2 x y) = windowMovedEventPosition mev
src/Dodge/Floor.hs
-2
View File
@@ -96,5 +96,3 @@ initialAnoTree = padSucWithCorridors $ treeFromTrunk
initialRoomTree :: RandomGen g => State g (Tree Room) initialRoomTree :: RandomGen g => State g (Tree Room)
initialRoomTree = do initialRoomTree = do
expandTree <$> mapM anoToRoomTree initialAnoTree expandTree <$> mapM anoToRoomTree initialAnoTree
src/Dodge/FloorItem.hs
+2 -2
View File
@@ -1,6 +1,6 @@
module Dodge.FloorItem module Dodge.FloorItem
(copyItemToFloor ( copyItemToFloor
,copyItemToFloorID , copyItemToFloorID
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
src/Dodge/Item.hs
+4 -5
View File
@@ -2,7 +2,6 @@ module Dodge.Item
where where
import Dodge.Data import Dodge.Data
import Dodge.Default import Dodge.Default
import Dodge.Picture
import Picture import Picture
import Geometry.Data import Geometry.Data
--import ShapePicture --import ShapePicture
@@ -22,8 +21,8 @@ keyToken n = defaultEquipment
keyPic :: Picture keyPic :: Picture
keyPic = color green $ keyPic = color green $
pictures [translate (-4) 0 $ thickCircle 4 2 pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)] ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)] ,thickLine 2 $ map toV2 [(4,0),(4,-4)]
] ]
latchkey :: Int -> Item latchkey :: Int -> Item
@@ -39,6 +38,6 @@ latchkey n = defaultEquipment
latchkeyPic :: Picture latchkeyPic :: Picture
latchkeyPic = color yellow $ latchkeyPic = color yellow $
pictures [translate (-4) 0 $ thickCircle 4 2 pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)] ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)] ,thickLine 2 $ map toV2 [(4,0),(4,-4)]
] ]
src/Dodge/Item/Weapon/BatteryGuns.hs
+2 -3
View File
@@ -23,7 +23,6 @@ import Geometry
import Picture import Picture
import Shape import Shape
import ShapePicture import ShapePicture
import Dodge.Picture
import LensHelp import LensHelp
import Data.List import Data.List
@@ -214,8 +213,8 @@ mvLaser phasev pos dir w pt
notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws notseen ws (_,Right wl) = not $ any (\w' -> _wlID w' == _wlID wl) ws
notseen _ _ = True notseen _ _ = True
pic = setLayer 1 $ pictures pic = setLayer 1 $ pictures
[ setDepth 19 . color (brightX 0 0.5 yellow) $ lineOfThickness 20 (pos:ps) [ setDepth 19 . color (brightX 0 0.5 yellow) $ thickLine 20 (pos:ps)
, setDepth 19.5 . color (brightX 10 1 yellow) $ lineOfThickness 3 (pos:ps) , setDepth 19.5 . color (brightX 10 1 yellow) $ thickLine 3 (pos:ps)
] ]
aTractorBeam :: Item -> Creature -> World -> World aTractorBeam :: Item -> Creature -> World -> World
src/Dodge/Item/Weapon/Decoration.hs
+1 -2
View File
@@ -6,7 +6,6 @@ module Dodge.Item.Weapon.Decoration
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Picture.Layer import Dodge.Picture.Layer
import Dodge.Picture
import Geometry.Data import Geometry.Data
import Picture import Picture
@@ -26,4 +25,4 @@ makeLaserScope p ep relFrac = Particle
} }
where where
lineAlphaThick a w = lineAlphaThick a w =
color (withAlpha a $ mixColors relFrac (1-relFrac) red green) $ lineOfThickness w [p,ep] color (withAlpha a $ mixColors relFrac (1-relFrac) red green) $ thickLine w [p,ep]
src/Dodge/Layout.hs
+1 -1
View File
@@ -65,7 +65,7 @@ putFloorTiles :: GenWorld -> GenWorld
putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw putFloorTiles gw = gw & gWorld . floorTiles .~ floorsFromGenWorld gw
setFloors :: GenWorld -> GenWorld setFloors :: GenWorld -> GenWorld
setFloors gw = putFloorTiles $ setTiles gw setFloors = putFloorTiles . setTiles
-- note the order of traversal of the rooms is important -- note the order of traversal of the rooms is important
-- hence the reverse -- hence the reverse
src/Dodge/LightSource.hs
+1 -2
View File
@@ -10,8 +10,7 @@ module Dodge.LightSource
, lsPosRad , lsPosRad
, lsColPosID , lsColPosID
, makeTlsTimeRadColPos , makeTlsTimeRadColPos
) ) where
where
import Dodge.Data import Dodge.Data
import Geometry.Data import Geometry.Data
import Dodge.Default import Dodge.Default
src/Dodge/Particle/TeslaArc.hs
+2 -3
View File
@@ -6,7 +6,6 @@ import Dodge.WorldEvent.Damage
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
import Dodge.Base.Collide import Dodge.Base.Collide
import Dodge.Picture
import Dodge.Particle.Spark import Dodge.Particle.Spark
import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.ThingsHit
import Dodge.RandomHelp import Dodge.RandomHelp
@@ -30,8 +29,8 @@ makeTeslaArcAt col pos dir = LinearParticle
} }
drawTeslaArc :: Particle -> Picture drawTeslaArc :: Particle -> Picture
drawTeslaArc pt = setLayer 1 $ pictures drawTeslaArc pt = setLayer 1 $ pictures
[ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ lineOfThickness 3 ps [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps
, setDepth 20 $ color (V4 0 0 0 0.5) $ lineOfThickness 10 ps , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps
] ]
where where
ps = _ptPoints pt ps = _ptPoints pt
src/Dodge/Path.hs
+1 -2
View File
@@ -4,8 +4,7 @@ module Dodge.Path
, makePathBetweenPs , makePathBetweenPs
, removePathsCrossing , removePathsCrossing
, pairsToGraph , pairsToGraph
) ) where
where
import Dodge.Data import Dodge.Data
import Dodge.Base.Collide import Dodge.Base.Collide
import Dodge.Zone import Dodge.Zone
src/Dodge/Picture.hs
-24
View File
@@ -6,30 +6,6 @@ module Dodge.Picture
import Geometry import Geometry
import Picture import Picture
-- {- |
-- Current thickness: 2 -}
-- thickLine :: [Point2] -> Picture
-- thickLine = lineOfThickness 2
{- |
Current thickness: 3 -}
vThickLine :: [Point2] -> Picture
vThickLine = lineOfThickness 3
{- |
Current thickness: 6 -}
vvThickLine :: [Point2] -> Picture
vvThickLine = lineOfThickness 6
-- shit this is ugly
lineOfThickness :: Float -> [Point2] -> Picture
lineOfThickness t = pictures . f
where
f (x:y:ys)
| x == y = f (x:ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys)
f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture wedgeOfThickness :: Float -> Point2 -> Point2 -> Picture
wedgeOfThickness t x y wedgeOfThickness t x y
| x == y = blank | x == y = blank
src/Dodge/RandomHelp.hs
+7 -4
View File
@@ -7,7 +7,7 @@ import Control.Monad.State
import Data.List import Data.List
randomRanges :: (Random a,RandomGen g) => [a] -> State g a randomRanges :: (Random a,RandomGen g) => [a] -> State g a
randomRanges xs = join $ takeOne $ f xs randomRanges = join . takeOne . f
where where
f (x:y:ys) = state (randomR (x,y)) : f ys f (x:y:ys) = state (randomR (x,y)) : f ys
f _ = [] f _ = []
@@ -51,12 +51,15 @@ shuffleTail :: RandomGen g => [a] -> State g [a]
shuffleTail (x:xs) = (x :) <$> shuffle xs shuffleTail (x:xs) = (x :) <$> shuffle xs
shuffleTail _ = undefined shuffleTail _ = undefined
-- select elements from a list randomly
-- each element has the same independent chance of being selected
randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a] randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
randomSelectionFromList p = filterM $ const $ randProb p randomSelectionFromList = filterM . const . randProb
randProb :: RandomGen g => Float -> State g Bool randProb :: RandomGen g => Float -> State g Bool
randProb p = do p1 <- state $ randomR (0,1) randProb p = do
return (p1 < p) p1 <- state $ randomR (0,1)
return (p1 < p)
randInCirc :: RandomGen g => Float -> State g Point2 randInCirc :: RandomGen g => Float -> State g Point2
randInCirc maxRad = do randInCirc maxRad = do
src/Dodge/SoundLogic.hs
-1
View File
@@ -158,4 +158,3 @@ soundMultiFrom (so:sos) pos sType mtime w
{- | Sets '_soundTime' to 0. -} {- | Sets '_soundTime' to 0. -}
stopSoundFrom :: SoundOrigin -> World -> World stopSoundFrom :: SoundOrigin -> World -> World
stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0) stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0)
src/Dodge/WallCreatureCollisions.hs
+2 -1
View File
@@ -103,7 +103,8 @@ pushOutFromWall rad cp2 (wp1,wp2)
isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad
pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2 pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2
pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls --pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls
pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst)
squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2
squashIntersectCirclePoint rad p cCen squashIntersectCirclePoint rad p cCen
src/Dodge/WorldEvent/Sound.hs
+7 -5
View File
@@ -3,8 +3,7 @@ module Dodge.WorldEvent.Sound
, mkSoundSplinterGlass , mkSoundSplinterGlass
, mkSoundSplinterBlock , mkSoundSplinterBlock
, originIDsAt , originIDsAt
) ) where
where
import Dodge.Data import Dodge.Data
import Dodge.SoundLogic import Dodge.SoundLogic
import Sound.Data import Sound.Data
@@ -20,10 +19,13 @@ originIDsAt so sids p w = soundStart so p sid Nothing $ set randGen g w
(sid,g) = _randGen w & runState (takeOne sids) (sid,g) = _randGen w & runState (takeOne sids)
mkSoundBreakGlass :: Point2 -> World -> World mkSoundBreakGlass :: Point2 -> World -> World
mkSoundBreakGlass = originIDsAt (GlassBreakSound 0) [glassShat1S,glassShat2S,glassShat3S,glassShat4S] mkSoundBreakGlass = originIDsAt (GlassBreakSound 0)
[glassShat1S,glassShat2S,glassShat3S,glassShat4S]
mkSoundSplinterGlass :: Point2 -> World -> World mkSoundSplinterGlass :: Point2 -> World -> World
mkSoundSplinterGlass = originIDsAt (GlassBreakSound 1) [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S] mkSoundSplinterGlass = originIDsAt (GlassBreakSound 1)
[smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S]
mkSoundSplinterBlock :: Point2 -> World -> World mkSoundSplinterBlock :: Point2 -> World -> World
mkSoundSplinterBlock = originIDsAt (BlockDegradeSound 1) [impact1S,impact2S,impact3S,impact4S] mkSoundSplinterBlock = originIDsAt (BlockDegradeSound 1)
[impact1S,impact2S,impact3S,impact4S]
src/Dodge/WorldEvent/ThingsHit.hs
+7 -19
View File
@@ -19,7 +19,7 @@ import Geometry
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Data.List import Data.List
import Data.Maybe import Data.Maybe
--import Data.Bifunctor import Data.Bifunctor
{- List those objects that appear on a line. -} {- List those objects that appear on a line. -}
thingsHit thingsHit
:: Point2 -- ^ Line start point :: Point2 -- ^ Line start point
@@ -34,16 +34,11 @@ thingsHit sp ep w
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep)) (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
. IM.elems . IM.elems
$ _creatures w $ _creatures w
hitWls = wallsOnLine sp ep wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- $ _walls w
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of f i = fromMaybe IM.empty . IM.lookup i
Just val -> val
_ -> IM.empty
wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls)
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) thingHit :: Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall)
thingHit sp ep = listToMaybe . thingsHit sp ep thingHit sp ep = listToMaybe . thingsHit sp ep
{- List objects that appear on a line. {- List objects that appear on a line.
@@ -69,16 +64,12 @@ wallsHit sp ep w
| sp == ep = [] | sp == ep = []
| otherwise = sortOn (dist sp . fst) wls | otherwise = sortOn (dist sp . fst) wls
where where
hitWls = wallsOnLine sp ep wls = IM.elems $ wallsOnLineHit sp ep
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]] | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- $ _walls w -- $ _walls w
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep)) (x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of f i = fromMaybe IM.empty . IM.lookup i
Just val -> val
_ -> IM.empty
wls = zip (map (fromJust . hitPoint) hitWls) hitWls
hitPoint w' = uncurry (intersectSegSeg sp ep) (_wlLine w')
thingsHitExceptCrLongLine thingsHitExceptCrLongLine
:: Maybe Int :: Maybe Int
@@ -96,13 +87,10 @@ thingsHitLongLine :: Point2 -> Point2 -> World -> [(Point2, Either Creature Wall
thingsHitLongLine sp ep w thingsHitLongLine sp ep w
| sp == ep = [] | sp == ep = []
| otherwise = sortOn (dist sp . fst) (crs ++ wls) | otherwise = sortOn (dist sp . fst) (crs ++ wls)
where where
crs = mapMaybe crs = mapMaybe
(\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep)) (\cr -> (,Left cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep))
. IM.elems . IM.elems
$ _creatures w $ _creatures w
-- $ creaturesAlongLine sp ep w -- $ creaturesAlongLine sp ep w
wls = zip (map (fromJust . hitPoint) hitWls) (map Right hitWls) wls = map (second Right) . IM.elems $ wallsOnLineHit sp ep $ _walls w
--hitWls = wallsOnLine sp ep $ wallsAlongLine sp ep w
hitWls = wallsOnLine sp ep $ _walls w
hitPoint wl = uncurry (intersectSegSeg sp ep) (_wlLine wl)
src/Picture.hs
+3 -2
View File
@@ -253,9 +253,10 @@ thickLine t = pictures . f
where where
f (x:y:ys) f (x:y:ys)
| x == y = f (x:ys) | x == y = f (x:ys)
| otherwise = polygon [x +.+ n x y, x -.- n x y, y -.- n x y, y +.+ n x y] : f (y:ys) | otherwise = polygon [x +.+ n, x -.- n, y -.- n, y +.+ n] : f (y:ys)
where
n = (t*0.5) *.* errorNormalizeV 42 (vNormal (x -.- y))
f _ = [] f _ = []
n a b = (t*0.5) *.* errorNormalizeV 42 (vNormal (a -.- b))
thickLineCol :: Float -> [(Point2,RGBA)] -> Picture thickLineCol :: Float -> [(Point2,RGBA)] -> Picture
{-# INLINE thickLineCol #-} {-# INLINE thickLineCol #-}