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.
This commit is contained in:
Griffin Smith 2020-02-17 18:01:57 -05:00
parent 1265155ae4
commit 22b7a9be84
5 changed files with 118 additions and 52 deletions

View file

@ -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

View file

@ -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

View file

@ -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>

View file

@ -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
<> ")"
)
]
]
]

View file

@ -13,30 +13,40 @@ main = defaultMain test
test :: TestTree
test = testGroup "Xanthous.Util.Graphics"
[ testGroup "circle"
[ 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)
[ 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)
@?= [ (-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)
]
]
--------------------------------------------------------------------------------