From 22b7a9be84b26d3c40d065fc0d699ad1ebcadb3c Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Mon, 17 Feb 2020 18:01:57 -0500 Subject: Drop Rasterific for non-filled circles Rasterific appears to generate some pretty surprising, if not completely wrong, circles at especially low sizes - this was resulting in unexpected behavior with vision calculation, including the character never being able to see directly to the left of them, among other things. This moves back to the old midpoint circle algorithm I pulled off of rosetta code, but only for the non-filled circle. The filled circle is still using the wonky algorithm for now, but at some point I'd love to refactor it such that empty circles are eg always a subset of non-filled circles. --- src/Xanthous/Data.hs | 23 ++++++++---- src/Xanthous/Data/EntityMap/Graphics.hs | 12 +++++-- src/Xanthous/Util/Graphics.hs | 43 +++++++++++++++++----- test/Xanthous/Data/EntityMap/GraphicsSpec.hs | 36 ++++++++++++------- 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 . +-- +-- Code taken from +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 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) ] ] + +-------------------------------------------------------------------------------- -- cgit 1.4.1