diff options
| -rw-r--r-- | src/Xanthous/Data.hs | 23 | ||||
| -rw-r--r-- | src/Xanthous/Data/EntityMap/Graphics.hs | 12 | ||||
| -rw-r--r-- | src/Xanthous/Util/Graphics.hs | 43 | ||||
| -rw-r--r-- | test/Xanthous/Data/EntityMap/GraphicsSpec.hs | 36 | ||||
| -rw-r--r-- | test/Xanthous/Util/GraphicsSpec.hs | 54 |
5 files changed, 117 insertions, 51 deletions
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index 1874b45e9047..2cfb8204d58c 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -68,6 +68,7 @@ module Xanthous.Data , move , asPosition , directionOf + , Cardinal(..) -- * , Corner(..) @@ -86,12 +87,12 @@ module Xanthous.Data , Hitpoints(..) ) where -------------------------------------------------------------------------------- -import Xanthous.Prelude hiding (Left, Down, Right, (.=)) +import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) -------------------------------------------------------------------------------- import Linear.V2 hiding (_x, _y) import qualified Linear.V2 as L import Linear.V4 hiding (_x, _y) -import Test.QuickCheck (Arbitrary, CoArbitrary, Function) +import Test.QuickCheck (Arbitrary, CoArbitrary, Function, elements) import Test.QuickCheck.Arbitrary.Generic import Data.Group import Brick (Location(Location), Edges(..)) @@ -267,11 +268,9 @@ data Direction where DownLeft :: Direction DownRight :: Direction Here :: Direction - deriving stock (Show, Eq, Generic) - -instance Arbitrary Direction where - arbitrary = genericArbitrary - shrink = genericShrink + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData) + deriving Arbitrary via GenericArbitrary Direction instance Opposite Direction where opposite Up = Down @@ -330,6 +329,16 @@ stepTowards (view _Position -> p₁) (view _Position -> p₂) let (_:p:_) = line p₁ p₂ in _Position # p +-- | Newtype controlling arbitrary generation to only include cardinal +-- directions ('Up', 'Down', 'Left', 'Right') +newtype Cardinal = Cardinal { getCardinal :: Direction } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, Function, CoArbitrary) + deriving newtype (Opposite) + +instance Arbitrary Cardinal where + arbitrary = Cardinal <$> elements [Up, Down, Left, Right] + -------------------------------------------------------------------------------- data Corner diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs index 9064855bdbae..d523c0555e4f 100644 --- a/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/src/Xanthous/Data/EntityMap/Graphics.hs @@ -17,8 +17,16 @@ import Xanthous.Game.State import Xanthous.Util.Graphics (circle, line) -------------------------------------------------------------------------------- -visiblePositions :: Entity e => Position -> Word -> EntityMap e -> Set Position -visiblePositions pos radius = setFromList . positions . visibleEntities pos radius +-- | Returns a set of positions that are visible, when taking into account +-- 'blocksVision', from the given position, within the given radius. +visiblePositions + :: Entity e + => Position + -> Word -- ^ Vision radius + -> EntityMap e + -> Set Position +visiblePositions pos radius + = setFromList . positions . visibleEntities pos radius -- | Returns a list of individual lines of sight, each of which is a list of -- entities at positions on that line of sight diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs index fc704abf64fd..ea1dbffe839b 100644 --- a/src/Xanthous/Util/Graphics.hs +++ b/src/Xanthous/Util/Graphics.hs @@ -30,16 +30,45 @@ import Linear.V2 -------------------------------------------------------------------------------- -circle :: (Num i, Integral i, Ix i) +-- | Generate a circle centered at the given point and with the given radius +-- using the <midpoint circle algorithm +-- https://en.wikipedia.org/wiki/Midpoint_circle_algorithm>. +-- +-- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell> +circle :: (Num i, Ord i) => (i, i) -- ^ center -> i -- ^ radius -> [(i, i)] -circle (ox, oy) radius - = pointsFromRaster (ox + radius) (oy + radius) - $ stroke 1 JoinRound (CapRound, CapRound) - $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) - $ fromIntegral radius +circle (x₀, y₀) radius + -- Four initial points, plus the generated points + = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points + where + -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets. + points = concatMap generatePoints $ unfoldr step initialValues + + generatePoints (x, y) + = [ (x₀ `xop` x', y₀ `yop` y') + | (x', y') <- [(x, y), (y, x)] + , xop <- [(+), (-)] + , yop <- [(+), (-)] + ] + initialValues = (1 - radius, 1, (-2) * radius, 0, radius) + + step (f, ddf_x, ddf_y, x, y) + | x >= y = Nothing + | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y')) + where + (f', ddf_y', y') | f >= 0 = (f + ddf_y' + ddf_x', ddf_y + 2, y - 1) + | otherwise = (f + ddf_x, ddf_y, y) + ddf_x' = ddf_x + 2 + x' = x + 1 + + +-- | Generate a *filled* circle centered at the given point and with the given +-- radius using the Rasterific package. Note that since this uses a different +-- implementation, this is not a strict superset of the 'circle' function +-- (unfortunately - would like to make that not the case!) filledCircle :: (Num i, Integral i, Ix i) => (i, i) -- ^ center -> i -- ^ radius @@ -72,8 +101,6 @@ pointsFromRaster w h raster $ renderDrawing @Word8 (fromIntegral w) (fromIntegral h) 0 $ withTexture (uniformTexture 1) raster - - -- | Draw a line between two points using Bresenham's line drawing algorithm -- -- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm> diff --git a/test/Xanthous/Data/EntityMap/GraphicsSpec.hs b/test/Xanthous/Data/EntityMap/GraphicsSpec.hs index 9347a1c1b569..55ae0d79dbb8 100644 --- a/test/Xanthous/Data/EntityMap/GraphicsSpec.hs +++ b/test/Xanthous/Data/EntityMap/GraphicsSpec.hs @@ -8,6 +8,7 @@ import Xanthous.Game.State import Xanthous.Data import Xanthous.Data.EntityMap import Xanthous.Data.EntityMap.Graphics +import Xanthous.Entities.Environment (Wall(..)) -------------------------------------------------------------------------------- main :: IO () @@ -16,19 +17,28 @@ main = defaultMain test test :: TestTree test = testGroup "Xanthous.Data.EntityMap.Graphics" [ testGroup "visiblePositions" - [ testCase "non-contiguous bug 1" $ - let charPos = Position 20 20 - gormlakPos = Position 17 19 - em = insertAt gormlakPos TestEntity - . insertAt charPos TestEntity - $ mempty - visPositions = visiblePositions charPos 12 em - in (gormlakPos `member` visPositions) @? - ( "not (" - <> show gormlakPos <> " `member` " - <> show visPositions - <> ")" - ) + [ testProperty "one step in each cardinal direction is always visible" + $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)-> + let em = review _EntityMap . map (, Wall) . toList $ wallPositions + em' = em & atPosition (move dir pos) %~ (Wall <|) + poss = visiblePositions pos r em' + in counterexample ("visiblePositions: " <> show poss) + $ move dir pos `member` poss + , testGroup "bugs" + [ testCase "non-contiguous bug 1" + $ let charPos = Position 20 20 + gormlakPos = Position 17 19 + em = insertAt gormlakPos TestEntity + . insertAt charPos TestEntity + $ mempty + visPositions = visiblePositions charPos 12 em + in (gormlakPos `member` visPositions) @? + ( "not (" + <> show gormlakPos <> " `member` " + <> show visPositions + <> ")" + ) + ] ] ] diff --git a/test/Xanthous/Util/GraphicsSpec.hs b/test/Xanthous/Util/GraphicsSpec.hs index ecd6dbe19197..a1eaf73e2845 100644 --- a/test/Xanthous/Util/GraphicsSpec.hs +++ b/test/Xanthous/Util/GraphicsSpec.hs @@ -13,30 +13,40 @@ main = defaultMain test test :: TestTree test = testGroup "Xanthous.Util.Graphics" [ testGroup "circle" - [ testCase "radius 12, origin 0" + [ testCase "radius 1, origin 2,2" + {- + | | 0 | 1 | 2 | 3 | + |---+---+---+---+---| + | 0 | | | | | + | 1 | | | x | | + | 2 | | x | | x | + | 3 | | | x | | + -} + $ (sort . unique @[] @[_]) (circle @Int (2, 2) 1) + @?= [ (1, 2) + , (2, 1), (2, 3) + , (3, 2) + ] + , testCase "radius 12, origin 0" $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12) - @?= [ (1,12) - , (2,12) - , (3,12) - , (4,12) - , (5,12) - , (6,11) - , (7,10) - , (7,11) - , (8,10) - , (9,9) - , (10,7) - , (10,8) - , (11,6) - , (11,7) - , (12,1) - , (12,2) - , (12,3) - , (12,4) - , (12,5) + @?= [ (-12,-4),(-12,-3),(-12,-2),(-12,-1),(-12,0),(-12,1),(-12,2) + , (-12,3),(-12,4),(-11,-6),(-11,-5),(-11,5),(-11,6),(-10,-7),(-10,7) + , (-9,-9),(-9,-8),(-9,8),(-9,9),(-8,-9),(-8,9),(-7,-10),(-7,10) + , (-6,-11),(-6,11),(-5,-11),(-5 ,11),(-4,-12),(-4,12),(-3,-12),(-3,12) + , (-2,-12),(-2,12),(-1,-12),(-1,12),(0,-12),(0,12),(1,-12),(1,12) + , (2,-12),(2,12),(3,-12),(3,12),(4,-12),(4,12),(5,-11),(5 ,11),(6,-11) + , (6,11),(7,-10),(7,10),(8,-9),(8,9),(9,-9),(9,-8),(9,8),(9,9),(10,-7) + , (10,7),(11,-6),(11,-5),(11,5),(11,6),(12,-4),(12,-3),(12,-2),(12,-1) + , (12,0), (12,1),(12,2),(12,3),(12,4) ] - ] + -- , testProperty "is a subset of filledCircle" $ \center radius -> + -- let circ = circle @Int center radius + -- filledCirc = filledCircle center radius + -- in counterexample ( "circle: " <> show circ + -- <> "\nfilledCircle: " <> show filledCirc) + -- $ setFromList circ `isSubsetOf` setFromList filledCirc + ] , testGroup "line" [ testProperty "starts and ends at the start and end points" $ \start end -> let ℓ = line @Int start end @@ -44,3 +54,5 @@ test = testGroup "Xanthous.Util.Graphics" $ length ℓ > 2 ==> (head ℓ === start) .&&. (head (reverse ℓ) === end) ] ] + +-------------------------------------------------------------------------------- |