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

Make item display universal

Browse Source
This commit is contained in:
justin
2022-06-19 12:56:30 +01:00
parent df1f3ad6b0
commit 541a04f1bc
22 changed files with 349 additions and 358 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+4 -259
View File
@@ -1,8 +1,8 @@
{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
{-# LANGUAGE BangPatterns #-} {-# LANGUAGE BangPatterns #-}
{- | {- |
Basic helpers. Basic helpers.
Consider splitting. -} These modules should have few dependencies. -}
module Dodge.Base module Dodge.Base
( module Dodge.Base ( module Dodge.Base
, module Dodge.Base.Arithmetic , module Dodge.Base.Arithmetic
@@ -20,20 +20,17 @@ import Dodge.Base.Arithmetic
import Dodge.Base.NewID import Dodge.Base.NewID
import Dodge.Base.Coordinate import Dodge.Base.Coordinate
import Dodge.Base.CardinalPoint import Dodge.Base.CardinalPoint
import Dodge.Zone --import Dodge.Zone
--import Dodge.Zone.Data --import Dodge.Zone.Data
import Dodge.Base.Window import Dodge.Base.Window
import Dodge.Base.Collide import Dodge.Base.Collide
import Geometry import Geometry
--import Picture --import Picture
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import FoldableHelp --import FoldableHelp
import qualified FoldlHelp as L
import Dodge.Base.You import Dodge.Base.You
import Control.Lens import Control.Lens
import Data.Monoid
import Data.Maybe
--import Data.Bifunctor --import Data.Bifunctor
--import qualified Data.IntSet as IS --import qualified Data.IntSet as IS
--import qualified Data.Set as S --import qualified Data.Set as S
@@ -42,34 +39,6 @@ import Data.Maybe
allWalls :: World -> IM.IntMap Wall allWalls :: World -> IM.IntMap Wall
allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone allWalls = IM.unions . concatMap IM.elems . IM.elems . _znObjects . _wallsZone
creatureNearPoint :: Point2 -> World -> Maybe Creature
creatureNearPoint = creatureNearPointI 1
creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature
creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
creaturesNearPoint = creaturesNearPointI 1
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]]
where
(x,y) = crZoneOfPoint p
f i m = fromMaybe IM.empty $ IM.lookup i m
-- possible BUG, occurs when used in thingsHitLongLine
creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
--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
-- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
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]
@@ -131,225 +100,6 @@ adjustIMZone f x y n = IM.adjust f' x
where where
f' = IM.adjust f'' y f' = IM.adjust f'' y
f'' = IM.adjust f n f'' = IM.adjust f n
--{- | Finds unused projectile key. -}
--newProjectileKey :: World -> Int
--newProjectileKey = IM.newKey . _props
--{- | Finds unused creature key. -}
--newCrKey :: World -> Int
--newCrKey = IM.newKey . _creatures
-- | Looks for overlap of a circle with walls.
-- If found, gives wall
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
overlapCircWallsReturnWall p rad
= L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
where
f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
-- | Looks for any collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
-- note that in this version the circle can overlap the wall
collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointAnyWallsReflect p1 p2
= getFirst
. foldMap (First . findPoint . _wlLine)
where
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
Nothing -> Nothing
-- | Looks for collision of a point with walls.
-- If found, gives collision point
-- If not found, returns point
collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWalls p1 p2
= foldr findPoint p2 . fmap _wlLine
where
findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
collidePointWallsFilter :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWallsFilter t p1 p2 = foldr findPoint p2 . fmap _wlLine . IM.filter t
where
findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
collidePointWallsFilter' :: (Wall -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWallsFilter' t p1 p2 = foldl' findPoint p2 . fmap _wlLine . IM.filter t
where
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
-- note that the "intersection" point is the center of the circle flush against the wall
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2)
where
findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl
getp (Left p) = p
getp (Right (p,_)) = p
doReflection p (x,y) = case intersectSegSeg p1 p x y of
Nothing -> Nothing
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
shiftByRad (a,b) =
(g $ a +.+ rad *.* normalizeV (a -.-b)
,g $ b +.+ rad *.* normalizeV (b -.-a)
)
where
g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls p1 p2 rad
= safeMinimumOn (dist p1 . fst)
. IM.mapMaybe
(( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ normalizeV (vNormal (x -.- y)))
)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
)
where
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
]
-- this shifts the wall out, and for outer corners extends the wall
-- not sure what this does for inner corners, hopefully won't cause a problem
-- the alternative would be to separately bounce off corner points...
-- unfortunately, doesn't allow for collisions when the circle spawns on the
-- wall
-- | Looks for first collision of a point with a list of lines.
-- If found, gives point and normal of wall.
--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
--collidePointLines p1 p2 ws
-- = safeMinimumOn f
-- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
-- . _wlLine') ws
-- where
-- f (a,_) = magV (p1 -.- a)
--
-- | Looks for first collision of a point with walls.
-- If found, gives point and normal of wall.
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws
= safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
collidePointCreatures p1 p2 = fmap fst
. safeMinimumOn snd
. IM.toList
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
-- | Returns the first creature id, if any, that a point intersects with, gives point
--in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 = fmap f
. safeMinimumOn (dist p1 . snd)
. IM.toList
. IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
where
f (cID,p) = (p,cID)
{- | Finds the first creature hit on a line.
Maybe evaluates the creature id and hit point. -}
collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
---- | Makes a creature not hittable.
--collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
--collidePointCrsWithoutPoint cid p1 p2 w
-- = fmap f
-- . safeMinimumOn (snd . snd)
-- . IM.toList
-- . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
-- . IM.delete cid
-- $ _creatures w
-- where
-- f (cID,(p,_)) = (p,cID)
{- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad
= any (\(x,y) -> circOnSeg x y p rad)
. fmap _wlLine
. IM.elems
. wallsNearPoint p
{- | Test whether there is a creature of weight 4 or greater near a line. -}
isHeavyCrNearLine
:: Float
-> [Point2]
-> World
-> Bool
isHeavyCrNearLine d (p1:p2:_)
= any (\c -> circOnSeg p1 p2 (_crPos c) (d + _crRad c))
. IM.filter (\cr -> _crMass cr > 4)
. _creatures
isHeavyCrNearLine _ _ = error "Testing whether creature is near empty line"
{- | Adds the distance to the creature radius, tests whether the center is in
the circle of this size centered at the point -}
crsNearPoint :: Float -> Point2 -> World -> Bool
crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
{- | Produce an unordered list of creatures on a line. -}
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnLine p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
. _creatures
{- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnThickLine thickness p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
. _creatures
{- | Find 'Maybe' the closest creature to a point, within a circle.
-}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r
= safeMinimumOn (dist p . _crPos)
. 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. -}
nearestCrInTri
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInTri p dir x
= safeMinimumOn (dist p . _crPos)
. IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
. _creatures
where
tri =
[p
,p +.+ rotateV (dir-pi/4) (V2 x 0)
,p +.+ rotateV (dir+pi/4) (V2 x 0)
]
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance.
The shapes within which creatures are searched are a triangle then rectangle. -}
nearestCrInFront
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInFront p dir x
= safeMinimumOn (dist p . _crPos)
. IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
. _creatures
where
rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
{- | Test whether a creature is in a polygon. -}
crInPolygon :: Creature -> [Point2] -> Bool
crInPolygon = pointInPolygon . _crPos
{- | Create a logistic function given three parameters. -} {- | Create a logistic function given three parameters. -}
logistic :: Float -> Float -> Float -> (Float -> Float) logistic :: Float -> Float -> Float -> (Float -> Float)
@@ -375,11 +125,6 @@ mvPointToward !ep !p
| dist p ep < 1 = ep | dist p ep < 1 = ep
| otherwise = p +.+ normalizeV (ep -.- p) | otherwise = p +.+ normalizeV (ep -.- p)
isAnimate :: Creature -> Bool
{-# INLINE isAnimate #-}
isAnimate cr = case _crActionPlan cr of
Inanimate -> False
_ -> True
sigmoid :: Floating a => a -> a sigmoid :: Floating a => a -> a
sigmoid x = x/sqrt(1+x^(2::Int)) sigmoid x = x/sqrt(1+x^(2::Int))
src/Dodge/Base/Collide.hs
+211
View File
@@ -16,6 +16,23 @@ module Dodge.Base.Collide
, wlIsSeeThrough , wlIsSeeThrough
, wallsOnCirc , wallsOnCirc
, wallsOnLineHit , wallsOnLineHit
, collideCircWalls
, collideCircWalls'
, circOnSomeWall
, collidePointWalls
, collidePointWallsNorm
, collidePointWalls'
, overlapCircWallsReturnWall
, collideCircCrsPoint
, collideCircCreatures
, collidePointCreatures
, collidePointAnyWallsReflect
, crsNearPoint
, crsOnLine
, crsOnThickLine
, nearestCrInRad
, nearestCrInTri
, nearestCrInFront
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Zone import Dodge.Zone
@@ -28,6 +45,7 @@ import Data.Maybe
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Control.Lens import Control.Lens
import qualified FoldlHelp as L import qualified FoldlHelp as L
import Data.Monoid
hasLOS :: Point2 -> Point2 -> World -> Bool hasLOS :: Point2 -> Point2 -> World -> Bool
{-# INLINE hasLOS #-} {-# INLINE hasLOS #-}
@@ -323,3 +341,196 @@ wallsOnCirc p r = IM.filter f
--wallNormal :: Wall -> Point2 --wallNormal :: Wall -> Point2
--wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine --wallNormal = normalizeV . vNormal . uncurry (-.-) . _wlLine
-- | Looks for overlap of a circle with walls.
-- If found, gives wall
overlapCircWallsReturnWall :: Point2 -> Float -> IM.IntMap Wall -> Maybe Wall
overlapCircWallsReturnWall p rad
= L.fold (safeMinimumOnMaybeL (fmap (dist p) . f . _wlLine))
where
f (a,b) = intersectSegSeg p (p -.- rad *.* vNormal (normalizeV (a -.- b))) a b
-- | Looks for any collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
-- note that in this version the circle can overlap the wall
collidePointAnyWallsReflect :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointAnyWallsReflect p1 p2
= getFirst
. foldMap (First . findPoint . _wlLine)
where
findPoint (x,y) = case intersectSegSeg p1 p2 x y of
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
Nothing -> Nothing
-- | Looks for collision of a point with walls.
-- If found, gives collision point
-- If not found, returns point
collidePointWalls :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWalls p1 p2 = foldr findPoint p2 . fmap _wlLine
where
findPoint (x,y) p = fromMaybe p $ intersectSegSeg p1 p x y
collidePointWalls' :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
collidePointWalls' p1 p2 = foldl' findPoint p2 . fmap _wlLine
where
findPoint p = fromMaybe p . uncurry (intersectSegSeg p1 p)
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
-- note that the "intersection" point is the center of the circle flush against the wall
collideCircWalls' :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls' p1 p2 rad = either (const Nothing) Just . foldr findPoint (Left p2)
where
findPoint wl eip = maybe eip Right $ doReflection (getp eip) $ shiftByRad $ _wlLine wl
getp (Left p) = p
getp (Right (p,_)) = p
doReflection p (x,y) = case intersectSegSeg p1 p x y of
Nothing -> Nothing
Just ip -> Just (ip +.+ normalizeV (vNormal (x -.- y)), reflectInParam 0.5 (x -.- y) (p2 -.- p1))
shiftByRad (a,b) =
(g $ a +.+ rad *.* normalizeV (a -.-b)
,g $ b +.+ rad *.* normalizeV (b -.-a)
)
where
g = ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
-- | Looks for first collision of a circle with walls.
-- If found, gives point and reflection velocity, reflection damped in normal.
collideCircWalls :: Point2 -> Point2 -> Float -> IM.IntMap Wall -> Maybe (Point2,Point2)
collideCircWalls p1 p2 rad
= safeMinimumOn (dist p1 . fst)
. IM.mapMaybe
(( \(x:y:_) -> fmap
((, reflectInParam 0.5 (x -.- y) (p2 -.- p1))
. (+.+ normalizeV (vNormal (x -.- y)))
)
(intersectSegSeg p1 p2 x y)
)
. shiftByRad . _wlLine
)
where
shiftByRad (a,b) = map ((rad *.* normalizeV (vNormal $ a -.- b)) +.+)
[a +.+ rad *.* normalizeV (a -.-b)
,b +.+ rad *.* normalizeV (b -.-a)
]
-- this shifts the wall out, and for outer corners extends the wall
-- not sure what this does for inner corners, hopefully won't cause a problem
-- the alternative would be to separately bounce off corner points...
-- unfortunately, doesn't allow for collisions when the circle spawns on the
-- wall
-- | Looks for first collision of a point with a list of lines.
-- If found, gives point and normal of wall.
--collidePointLines :: Point2 -> Point2 -> [Wall'] -> Maybe (Point2,Point2)
--collidePointLines p1 p2 ws
-- = safeMinimumOn f
-- $ mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
-- . _wlLine') ws
-- where
-- f (a,_) = magV (p1 -.- a)
--
-- | Looks for first collision of a point with walls.
-- If found, gives point and normal of wall.
collidePointWallsNorm :: Point2 -> Point2 -> IM.IntMap Wall -> Maybe (Point2,Point2)
collidePointWallsNorm p1 p2 ws
= safeMinimumOn (dist p1 . fst)
$ IM.mapMaybe (( \(x,y) -> intersectSegSeg p1 p2 x y <&> ( , vNormal $ x -.- y ) )
. _wlLine) ws
-- | Returns the first creature, if any, that a point intersects with.
collidePointCreatures :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe Int
collidePointCreatures p1 p2 = fmap fst
. safeMinimumOn snd
. IM.toList
. IM.mapMaybe (\x -> dist p1 <$> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
-- | As for 'collidePointCreatures', only increases the radius of creatures by a
--fixed amount, thus collides a moving circle with creaures.
collideCircCreatures :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe Int
collideCircCreatures p1 p2 rad = collidePointCreatures p1 p2 . fmap (crRad +~ rad)
-- | Returns the first creature id, if any, that a point intersects with, gives point
--in creature on line.
collidePointCrsPoint :: Point2 -> Point2 -> IM.IntMap Creature -> Maybe (Point2,Int)
collidePointCrsPoint p1 p2 = fmap f
. safeMinimumOn (dist p1 . snd)
. IM.toList
. IM.mapMaybe (\x -> intersectCircSegFirst (_crPos x) (_crRad x) p1 p2)
where
f (cID,p) = (p,cID)
{- | Finds the first creature hit on a line.
Maybe evaluates the creature id and hit point. -}
collideCircCrsPoint :: Point2 -> Point2 -> Float -> IM.IntMap Creature -> Maybe (Point2,Int)
collideCircCrsPoint p1 p2 rad = collidePointCrsPoint p1 p2 . fmap (crRad +~ rad)
---- | Makes a creature not hittable.
--collidePointCrsWithoutPoint :: Int -> Point2 -> Point2 -> World -> Maybe (Point2,Int)
--collidePointCrsWithoutPoint cid p1 p2 w
-- = fmap f
-- . safeMinimumOn (snd . snd)
-- . IM.toList
-- . IM.mapMaybe (\x -> collidePointCirc'' p1 p2 (_crRad x) (_crPos x))
-- . IM.delete cid
-- $ _creatures w
-- where
-- f (cID,(p,_)) = (p,cID)
{- | Test if a circle collides with any wall.
- Note no check on whether the wall is walkable. -}
circOnSomeWall :: Point2 -> Float -> World -> Bool
circOnSomeWall p rad
= any (\(x,y) -> circOnSeg x y p rad)
. fmap _wlLine
. IM.elems
. wallsNearPoint p
{- | Adds the distance to the creature radius, tests whether the center is in
the circle of this size centered at the point -}
crsNearPoint :: Float -> Point2 -> World -> Bool
crsNearPoint d p = any (\c -> dist (_crPos c) p < (d + _crRad c)) . _creatures
{- | Produce an unordered list of creatures on a line. -}
crsOnLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnLine p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr))
. _creatures
{- | Produce an unordered list of creatures on a wide line. -}
crsOnThickLine :: Float -> Point2 -> Point2 -> World -> IM.IntMap Creature
crsOnThickLine thickness p1 p2
= IM.filter (\cr -> circOnSeg p1 p2 (_crPos cr) (_crRad cr + thickness))
. _creatures
{- | Find 'Maybe' the closest creature to a point, within a circle.
-}
nearestCrInRad :: Point2 -> Float -> World -> Maybe Creature
nearestCrInRad p r
= safeMinimumOn (dist p . _crPos)
. 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. -}
nearestCrInTri
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInTri p dir x
= safeMinimumOn (dist p . _crPos)
. IM.filter (\cr -> pointInPolygon (_crPos cr) tri)
. _creatures
where
tri =
[p
,p +.+ rotateV (dir-pi/4) (V2 x 0)
,p +.+ rotateV (dir+pi/4) (V2 x 0)
]
{- | Find 'Maybe' the closes creature in front of a point in a given direction for
a given distance.
The shapes within which creatures are searched are a triangle then rectangle. -}
nearestCrInFront
:: Point2
-> Float -- ^ Direction (radians +ve anticlockwise from x-axis).
-> Float -- ^ Distance.
-> World -> Maybe Creature
nearestCrInFront p dir x
= safeMinimumOn (dist p . _crPos)
. IM.filter (\cr -> pointInPolygon (_crPos cr) rec)
. _creatures
where
rec = [p, pR, pR1, pL1, pL ]
pR = p +.+ rotateV (dir - pi*(3/8)) (V2 (x/2) 0)
pL = p +.+ rotateV (dir + pi*(3/8)) (V2 (x/2) 0)
pR1 = pR +.+ rotateV dir (V2 (x/2) 0)
pL1 = pL +.+ rotateV dir (V2 (x/2) 0)
src/Dodge/Creature/ReaderUpdate.hs
+1
View File
@@ -18,6 +18,7 @@ import Dodge.Data
import Dodge.Creature.Test import Dodge.Creature.Test
import Dodge.Creature.Volition import Dodge.Creature.Volition
import Dodge.Base import Dodge.Base
import Dodge.Zone
import Geometry import Geometry
import FoldableHelp import FoldableHelp
src/Dodge/Creature/Test.hs
+6
View File
@@ -108,3 +108,9 @@ crNearSeg d p1 p2 cr = circOnSeg p1 p2 (_crPos cr) (_crRad cr + d)
crNearPoint :: Float -> Point2 -> Creature -> Bool crNearPoint :: Float -> Point2 -> Creature -> Bool
crNearPoint d p cr = dist (_crPos cr) p < d + _crRad cr crNearPoint d p cr = dist (_crPos cr) p < d + _crRad cr
isAnimate :: Creature -> Bool
{-# INLINE isAnimate #-}
isAnimate cr = case _crActionPlan cr of
Inanimate -> False
_ -> True
src/Dodge/Data.hs
+1 -2
View File
@@ -506,7 +506,6 @@ data Item = Item
, _itIsHeld :: Bool , _itIsHeld :: Bool
, _itEffect :: ItEffect , _itEffect :: ItEffect
, _itInvSize :: Float , _itInvSize :: Float
, _itInvDisplay :: Item -> [String]
, _itInvColor :: Color , _itInvColor :: Color
, _itTargeting :: Targeting , _itTargeting :: Targeting
, _itDimension :: ItemDimension , _itDimension :: ItemDimension
@@ -1400,7 +1399,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutButton {_putButton :: Button} | PutButton {_putButton :: Button}
| PutProp Prop | PutProp Prop
| PutTerminal {_unputTerminal :: Terminal} | PutTerminal {_unputTerminal :: Terminal}
| PutFlIt Item | PutFlIt {_putItem :: Item}
| PutPPlate PressPlate | PutPPlate PressPlate
| PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2] } | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2] }
| PutCoord Point2 | PutCoord Point2
src/Dodge/Default/Item.hs
+1 -59
View File
@@ -1,21 +1,10 @@
module Dodge.Default.Item module Dodge.Default.Item
( basicItemDisplay ( defaultItem
, maybeWarmupStatus
, maybeRateStatus
, moduleStrings
, defaultItem
) where ) where
import Dodge.Data import Dodge.Data
import Padding
import Dodge.Inventory.ItemSpace
import Dodge.Module
import Picture import Picture
import Shape import Shape
import Data.Maybe
import Data.Sequence
import Control.Lens
defaultItem :: Item defaultItem :: Item
defaultItem = Item defaultItem = Item
{ _itCurseStatus = Uncursed { _itCurseStatus = Uncursed
@@ -25,7 +14,6 @@ defaultItem = Item
, _itID = Nothing , _itID = Nothing
, _itIsHeld = False , _itIsHeld = False
, _itInvColor = yellow , _itInvColor = yellow
, _itInvDisplay = basicItemDisplay
, _itInvSize = 1 , _itInvSize = 1
, _itInvPos = Nothing , _itInvPos = Nothing
, _itDimension = ItemDimension 0 0 NoPortage (const mempty) , _itDimension = ItemDimension 0 0 NoPortage (const mempty)
@@ -39,51 +27,5 @@ defaultItem = Item
, _itValue = ItemValue 0 MundaneItem , _itValue = ItemValue 0 MundaneItem
} }
{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -}
-- TODO make work on remote launchers
basicItemDisplay :: Item -> [String]
basicItemDisplay it = Prelude.take (itSlotsTaken it) $
(midPadL 15 ' ' thename (' ' : thenumber) ++ theparam)
: catMaybes [maybeWarmupStatus it]
++ moduleStrings it ++ repeat "*"
where
thename = show . _iyBase $ _itType it
thenumber = case it ^? itConsumption of
Just am@LoadableAmmo{} -> case _laReloadState am of
Nothing' -> show (_laLoaded am)
Just' x -> show x ++ "R" ++ show (_laLoaded am)
Just am@ChargeableAmmo{} -> show $ _wpCharge am
Just x@ItemItselfConsumable{} -> show (_icAmount x)
Just NoConsumption -> ""
Nothing -> ""
theparam = fromMaybe []
. listToMaybe
$ mapMaybe ($ it)
[ maybeModeStatus
-- , maybeWarmupStatus
-- , maybeRateStatus
]
-- this can be moved to Dodge/Module and unified with moduleSizes
maybeModeStatus :: Item -> Maybe String
maybeModeStatus it = case it ^? itAttachment of
Just AttachCharMode {_atCharMode = (c :<| _)} -> Just [' ',c]
Just AttachMode {_atMode = i} -> Just $ show i
_ -> Nothing
maybeRateStatus :: Item -> Maybe String
maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of
Nothing -> Nothing
_ -> Just $ leftPad 3 ' ' (show (_rateMax . _useDelay $ _itUse it))
maybeWarmupStatus :: Item -> Maybe String
maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of
Nothing -> Nothing
Just m -> case m - (_warmTime . _useDelay $ _itUse it) of
x | x <= 1 -> Just "*WARM"
| otherwise -> let n = show x
in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n
defaultItemType :: ItemType defaultItemType :: ItemType
defaultItemType = ItemType NOTDEFINED mempty NoStack defaultItemType = ItemType NOTDEFINED mempty NoStack
src/Dodge/Default/Weapon.hs
-1
View File
@@ -107,7 +107,6 @@ defaultGun = defaultItem
, _itInvPos = Nothing , _itInvPos = Nothing
, _itIsHeld = False , _itIsHeld = False
, _itEffect = NoItEffect , _itEffect = NoItEffect
, _itInvDisplay = basicItemDisplay
, _itInvColor = white , _itInvColor = white
, _itInvSize = 1 , _itInvSize = 1
, _itParams = NoParams , _itParams = NoParams
src/Dodge/Floor.hs
+1 -5
View File
@@ -39,11 +39,7 @@ import Data.List (intersperse)
initialAnoTree :: Annotation initialAnoTree :: Annotation
initialAnoTree = OnwardList initialAnoTree = OnwardList
$ intersperse (AnTree corDoor) $ intersperse (AnTree corDoor)
-- [ IntAnno $ AnTree . startRoom [ IntAnno $ AnTree . startRoom
[ AnRoom tanksPipesRoom
, AnRoom tanksPipesRoom
, AnRoom $ tanksRoom [] []
, AnRoom roomPillarsPassage
, AnTree firstBreather , AnTree firstBreather
-- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) -- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
, AnRoom $ roomCCrits 10 , AnRoom $ roomCCrits 10
src/Dodge/Item/Display.hs
+60
View File
@@ -0,0 +1,60 @@
module Dodge.Item.Display where
import Dodge.Module
import Dodge.Data
import Dodge.Inventory.ItemSpace
import Padding
import LensHelp
import Data.Maybe
import Data.Sequence
itemString :: Item -> String
itemString = head . itemDisplay
{- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. -}
-- TODO make work on remote launchers
itemDisplay :: Item -> [String]
itemDisplay it = Prelude.take (itSlotsTaken it) $
(midPadL 15 ' ' thename (' ' : thenumber) ++ theparam)
: catMaybes [maybeWarmupStatus it]
++ moduleStrings it ++ repeat "*"
where
thename = show . _iyBase $ _itType it
thenumber = case it ^? itConsumption of
Just am@LoadableAmmo{} -> case _laReloadState am of
Nothing' -> show (_laLoaded am)
Just' x -> show x ++ "R" ++ show (_laLoaded am)
Just am@ChargeableAmmo{} -> show $ _wpCharge am
Just x@ItemItselfConsumable{} -> show (_icAmount x)
Just NoConsumption -> ""
Nothing -> ""
theparam = fromMaybe []
. listToMaybe
$ mapMaybe ($ it)
[ maybeModeStatus
-- , maybeWarmupStatus
-- , maybeRateStatus
]
-- & itInvDisplay .~ \it -> head (basicItemDisplay it) :
-- ["*FIRERATE:" ++ fromMaybe "" (maybeRateStatus it)
-- ]
maybeWarmupStatus :: Item -> Maybe String
maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of
Nothing -> Nothing
Just m -> case m - (_warmTime . _useDelay $ _itUse it) of
x | x <= 1 -> Just "*WARM"
| otherwise -> let n = show x
in Just $ Prelude.take (5 - Prelude.length n) "*WARM" ++ n
maybeModeStatus :: Item -> Maybe String
maybeModeStatus it = case it ^? itAttachment of
Just AttachCharMode {_atCharMode = (c :<| _)} -> Just [' ',c]
Just AttachMode {_atMode = i} -> Just $ show i
_ -> Nothing
maybeRateStatus :: Item -> Maybe String
maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of
Nothing -> Nothing
_ -> Just $ leftPad 3 ' ' (show (_rateMax . _useDelay $ _itUse it))
src/Dodge/Item/Equipment.hs
-4
View File
@@ -139,10 +139,6 @@ flatShield = defaultEquipment
, _heldScroll = \_ _ -> id , _heldScroll = \_ _ -> id
} }
, _itInvSize = 3 , _itInvSize = 3
, _itInvDisplay = \it -> head (basicItemDisplay it) :
["*" ++ replicate 13 ' ' ++ "*"
,"*" ++ replicate 13 ' ' ++ "*"
]
} }
& itType . iyBase .~ FLATSHIELD & itType . iyBase .~ FLATSHIELD
flatShieldEquipSPic :: Item -> SPic flatShieldEquipSPic :: Item -> SPic
src/Dodge/Item/Weapon/BulletGun/Rod.hs
-5
View File
@@ -7,7 +7,6 @@ module Dodge.Item.Weapon.BulletGun.Rod
, machineGun , machineGun
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Default.Item
import Dodge.Item.Weapon.BulletGun.Clip import Dodge.Item.Weapon.BulletGun.Clip
import Dodge.Particle.HitEffect import Dodge.Particle.HitEffect
import Dodge.Particle.Damage import Dodge.Particle.Damage
@@ -33,7 +32,6 @@ import Shape
--import Sound.Data --import Sound.Data
import LensHelp import LensHelp
import Data.Maybe
--import qualified Data.Sequence as Seq --import qualified Data.Sequence as Seq
--import Control.Lens --import Control.Lens
--import Control.Monad.State --import Control.Monad.State
@@ -150,6 +148,3 @@ machineGun = bangRod
& itConsumption . laReloadTime .~ 75 & itConsumption . laReloadTime .~ 75
& itInvSize .~ 3 & itInvSize .~ 3
& itParams. torqueAfter .~ 0.2 -- not sure if this is necessary? & itParams. torqueAfter .~ 0.2 -- not sure if this is necessary?
& itInvDisplay .~ \it -> head (basicItemDisplay it) :
["*FIRERATE:" ++ fromMaybe "" (maybeRateStatus it)
]
src/Dodge/Item/Weapon/ExtraEffect.hs
+1
View File
@@ -16,6 +16,7 @@ module Dodge.Item.Weapon.ExtraEffect
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base import Dodge.Base
import Dodge.Zone
import Dodge.SoundLogic import Dodge.SoundLogic
--import Dodge.Item.Weapon.Decoration --import Dodge.Item.Weapon.Decoration
import Dodge.Item.Weapon.UseEffect import Dodge.Item.Weapon.UseEffect
src/Dodge/Placement/Instance/Door.hs
+1 -1
View File
@@ -5,7 +5,7 @@ module Dodge.Placement.Instance.Door
, switchDoor -- not used 9/3/22 , switchDoor -- not used 9/3/22
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base --import Dodge.Base
import Color import Color
import Geometry import Geometry
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
src/Dodge/Render/HUD.hs
+4 -3
View File
@@ -3,6 +3,7 @@ module Dodge.Render.HUD
( hudDrawings ( hudDrawings
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Item.Display
import Dodge.Combine import Dodge.Combine
import Dodge.Clock import Dodge.Clock
import Dodge.Base import Dodge.Base
@@ -281,7 +282,7 @@ invDimColor :: Color
invDimColor = greyN 0.7 invDimColor = greyN 0.7
closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture] closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture]
closeObjectToTextPictures nfreeslots e = case e of closeObjectToTextPictures nfreeslots e = case e of
Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ _itInvDisplay it it Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it
Right bt -> [color yellow $ textindent $ _btText bt] Right bt -> [color yellow $ textindent $ _btText bt]
where where
textindent = text . (replicate clObjIntIn ' '++) textindent = text . (replicate clObjIntIn ' '++)
@@ -369,9 +370,9 @@ mainListCursor c = openCursorAt 120 c 5 0
itemText :: Item -> [Picture] itemText :: Item -> [Picture]
{-# INLINE itemText #-} {-# INLINE itemText #-}
itemText it = f $ case _itCurseStatus it of itemText it = f $ case _itCurseStatus it of
UndroppableIdentified -> map (color yellow . text) (_itInvDisplay it it) UndroppableIdentified -> map (color yellow . text) (itemDisplay it)
-- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90))) -- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90)))
_ -> map (color thecolor . text) (_itInvDisplay it it) _ -> map (color thecolor . text) (itemDisplay it)
where where
thecolor = _itInvColor it thecolor = _itInvColor it
f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*"))
src/Dodge/Room/Breather.hs
+1 -2
View File
@@ -31,8 +31,7 @@ import Dodge.Room.Containing
firstBreather :: State StdGen (MetaTree Room String) firstBreather :: State StdGen (MetaTree Room String)
firstBreather = do firstBreather = do
itms <- takeOne itms <- takeOne
[[] [[itemFromBase $ CRAFT TUBE]
,[itemFromBase $ CRAFT TUBE]
,[itemFromBase $ CRAFT PIPE] ,[itemFromBase $ CRAFT PIPE]
,[itemFromBase $ CRAFT HARDWARE] ,[itemFromBase $ CRAFT HARDWARE]
,[itemFromBase $ CRAFT CAN] ,[itemFromBase $ CRAFT CAN]
src/Dodge/Room/Containing.hs
+5 -1
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-} --{-# LANGUAGE TupleSections #-}
module Dodge.Room.Containing where module Dodge.Room.Containing where
import Dodge.Data import Dodge.Data
import Dodge.Item.Display
import Dodge.Tree import Dodge.Tree
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
@@ -16,7 +17,9 @@ import Geometry
--import Dodge.Item.Equipment --import Dodge.Item.Equipment
roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String) roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String)
roomsContaining crs its = tToBTree "roomsContaining" <$> roomsContaining' crs its roomsContaining crs its = tToBTree str <$> roomsContaining' crs its
where
str = "roomsContaining "++ concatMap _crName crs ++ concatMap (head . itemDisplay) its
roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room) roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room)
roomsContaining' crs its = do roomsContaining' crs its = do
@@ -24,6 +27,7 @@ roomsContaining' crs its = do
[ roomPillarsSquare <&> rmPmnts .++~ crsItmsUnused crs its [ roomPillarsSquare <&> rmPmnts .++~ crsItmsUnused crs its
, randomFourCornerRoomCrsIts crs its , randomFourCornerRoomCrsIts crs its
, tanksRoom crs its , tanksRoom crs its
, tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its
, roomPillarsContaining crs its , roomPillarsContaining crs its
, roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its , roomPillarsPassage <&> rmPmnts .++~ crsItmsUnused crs its
] ]
src/Dodge/Room/Room.hs
+14 -12
View File
@@ -10,6 +10,7 @@ module Dodge.Room.Room
, corDoor , corDoor
) where ) where
import Dodge.Cleat import Dodge.Cleat
import Dodge.Item.Display
import Dodge.Data import Dodge.Data
import Dodge.PlacementSpot import Dodge.PlacementSpot
import Dodge.RoomLink import Dodge.RoomLink
@@ -135,8 +136,8 @@ roomCenterPillar = do
] ]
{- Probabilites of the type of the first floor weapon. -} {- Probabilites of the type of the first floor weapon. -}
randFirstWeapon :: State StdGen PSType randFirstWeapon :: State StdGen Item
randFirstWeapon = takeOne $ map PutFlIt $ randFirstWeapon = takeOne $
replicate 10 pistol replicate 10 pistol
++ replicate 5 (bangStick 4) ++ replicate 5 (bangStick 4)
++ replicate 5 (bangCaneX 3) ++ replicate 5 (bangCaneX 3)
@@ -148,7 +149,7 @@ weaponEmptyRoom = do
w <- state $ randomR (220,300) w <- state $ randomR (220,300)
h <- state $ randomR (220,300) h <- state $ randomR (220,300)
let plmnts = let plmnts =
[sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon [sPS (V2 (w/2) (h-40)) 0 $ RandPS $ fmap PutFlIt randFirstWeapon
,sPS (V2 20 20) (pi/2) randC1 ,sPS (V2 20 20) (pi/2) randC1
,sPS (V2 (w-20) 20) (pi/2) randC1 ,sPS (V2 (w-20) 20) (pi/2) randC1
,mntLightLnkCond useUnusedLnk ,mntLightLnkCond useUnusedLnk
@@ -160,7 +161,7 @@ weaponEmptyRoom = do
weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String) weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String)
weaponUnderCrits i = do weaponUnderCrits i = do
let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS randFirstWeapon) let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS $ fmap PutFlIt randFirstWeapon)
continuationRoom = treePost continuationRoom = treePost
[ addwpat (V2 20 0) corridorN [ addwpat (V2 20 0) corridorN
, addwpat (V2 20 0) corridorN , addwpat (V2 20 0) corridorN
@@ -185,13 +186,13 @@ weaponBehindPillar = do
return $ treePost return $ treePost
[ corridor [ corridor
, rcp & rmPmnts ++.~ , rcp & rmPmnts ++.~
[sPS wpos wpa $ RandPS randFirstWeapon [sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon
,sPS cpos (argV $ V2 120 80 -.- cpos) randC1 ,sPS cpos (argV $ V2 120 80 -.- cpos) randC1
] ]
, cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN
] ]
weaponBetweenPillars :: RandomGen g => State g (Tree Room) weaponBetweenPillars :: State StdGen (MetaTree Room String)
weaponBetweenPillars = do weaponBetweenPillars = do
(w,wn) <- takeOne [(240,2),(340,3)] (w,wn) <- takeOne [(240,2),(340,3)]
(h,hn) <- takeOne [(240,2),(340,3)] (h,hn) <- takeOne [(240,2),(340,3)]
@@ -202,13 +203,14 @@ weaponBetweenPillars = do
, any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r) , any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r)
] ]
ncrits <- state $ randomR (1,3) ncrits <- state $ randomR (1,3)
wp <- randFirstWeapon
critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r -> critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r ->
rpIsOnPath rp rpIsOnPath rp
&& _rpPlacementUse rp == 0 && _rpPlacementUse rp == 0
&& all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r) && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r)
fmap pure $ roomPillars 30 w h wn hn (fmap pure $ roomPillars 30 w h wn hn
<&> rmPmnts .++~ sps wpPos (RandPS randFirstWeapon) : map (`sps` randC1) critPlacementSpots <&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [ sps wpPos (PutFlIt wp) ]
<&> cleatOnward <&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp)
weaponLongCorridor :: RandomGen g => State g (Tree Room) weaponLongCorridor :: RandomGen g => State g (Tree Room)
weaponLongCorridor = do weaponLongCorridor = do
@@ -222,7 +224,7 @@ weaponLongCorridor = do
return $ Node rt [branch1,branch2] return $ Node rt [branch1,branch2]
where where
putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ] putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ]
putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)]
critInDeadEnd :: Room critInDeadEnd :: Room
critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1] critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1]
@@ -239,12 +241,12 @@ deadEndRoom = defaultRoom
where where
lnks = [(V2 0 30 ,0) ] lnks = [(V2 0 30 ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -} {- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => Int -> State g (MetaTree Room String) weaponRoom :: Int -> State StdGen (MetaTree Room String)
weaponRoom i = join $ takeOne weaponRoom i = join $ takeOne
[ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom"
, weaponUnderCrits i -- this int is used for PickOnePlacement , weaponUnderCrits i -- this int is used for PickOnePlacement
, weaponBehindPillar >>= rToOnward "weaponBehindPillar" , weaponBehindPillar >>= rToOnward "weaponBehindPillar"
, weaponBetweenPillars >>= rToOnward "weaponBetweenPillars" , weaponBetweenPillars-- >>= rToOnward "weaponBetweenPillars"
, weaponLongCorridor >>= rToOnward "weaponLongCorridor" , weaponLongCorridor >>= rToOnward "weaponLongCorridor"
] ]
src/Dodge/Room/Start.hs
+1 -1
View File
@@ -56,7 +56,7 @@ powerFakeout = do
,cleatOnward door] ,cleatOnward door]
-- the i is used either for a PickOnePlacement or a room id, this is not great -- the i is used either for a PickOnePlacement or a room id, this is not great
startRoom :: RandomGen g => Int -> State g (MetaTree Room String) startRoom :: Int -> State StdGen (MetaTree Room String)
startRoom i = join $ takeOne startRoom i = join $ takeOne
[ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i
, rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit"
src/Dodge/Tree/Compose.hs
+1 -1
View File
@@ -126,4 +126,4 @@ numMetaTree' (MTree lab mn bs) = do
return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs' return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs'
showIntsString :: ([Int],String) -> String showIntsString :: ([Int],String) -> String
showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show is)) ++ ':':s showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':':s
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -210,7 +210,7 @@ farWallDistDirection :: Point2 -> Configuration -> World -> (Float,Float,Float,F
--farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps --farWallDist p cfig w = (winFac /) . min maxViewDistance $ ssfold (> maxViewDistance) findMax 1 vps
farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps farWallDistDirection p cfig w = foldr (m . f) (0,0,0,0) vps
where where
f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWallsFilter' wlIsOpaque p q wos -.- p f q = g $ rotateV (negate $ _cameraRot w) $ collidePointWalls' p q (IM.filter wlIsOpaque wos) -.- p
g (V2 x y) = (y, negate y, x, negate x) g (V2 x y) = (y, negate y, x, negate x)
m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w') m (a,b,c,d) (x,y,z,w') = (max a x, max b y, max c z, max d w')
vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs vps = concatMap _grViewpoints grs ++ extendedViewPoints p grs
src/Dodge/WorldEvent/SpawnParticle.hs
-1
View File
@@ -8,7 +8,6 @@ module Dodge.WorldEvent.SpawnParticle
, concBall , concBall
) where ) where
import Dodge.Data import Dodge.Data
import Dodge.Base
import Dodge.Zone import Dodge.Zone
import Dodge.Particle.HitEffect.ExpireAndDamage import Dodge.Particle.HitEffect.ExpireAndDamage
import Dodge.Particle.Damage import Dodge.Particle.Damage
src/Dodge/Zone.hs
+35
View File
@@ -17,12 +17,18 @@ module Dodge.Zone
, wallsNearZones , wallsNearZones
, zoneOfSight , zoneOfSight
, flattenIMIMIM , flattenIMIMIM
, creaturesNearPointI
, creaturesNearPoint
, creatureNearPoint
, creatureNearPointI
, creaturesAlongLine
) )
where where
import Dodge.Data import Dodge.Data
import Dodge.Base.Window import Dodge.Base.Window
import Geometry import Geometry
import Geometry.Zone import Geometry.Zone
import qualified FoldlHelp as L
import Data.Maybe import Data.Maybe
import Data.List import Data.List
@@ -179,3 +185,32 @@ wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1
flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a flattenIMIMIM :: IM.IntMap (IM.IntMap (IM.IntMap a)) -> IM.IntMap a
flattenIMIMIM = IM.unions . fmap IM.unions flattenIMIMIM = IM.unions . fmap IM.unions
creatureNearPoint :: Point2 -> World -> Maybe Creature
creatureNearPoint = creatureNearPointI 1
creatureNearPointI :: Int -> Point2 -> World -> Maybe Creature
creatureNearPointI n p = L.fold (L.minimumOn (dist p . _crPos)) . creaturesNearPointI n p
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
creaturesNearPoint = creaturesNearPointI 1
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]]
where
(x,y) = crZoneOfPoint p
f i m = fromMaybe IM.empty $ IM.lookup i m
-- possible BUG, occurs when used in thingsHitLongLine
creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
--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
-- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
f i = fromMaybe IM.empty . IM.lookup i
-- f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty