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

@@ -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)
+  deriving stock (Show, Eq, Ord, Generic)
-
+  deriving anyclass (CoArbitrary, Function, NFData)
-instance Arbitrary Direction where
+  deriving Arbitrary via GenericArbitrary Direction
-  arbitrary = genericArbitrary
-  shrink = genericShrink
 
 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

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
+-- | Returns a set of positions that are visible, when taking into account
-visiblePositions pos radius = setFromList . positions . visibleEntities pos radius
+-- '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

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
+circle (x₀, y₀) radius
-  = pointsFromRaster (ox + radius) (oy + radius)
+  -- Four initial points, plus the generated points
-  $ stroke 1 JoinRound (CapRound, CapRound)
+  = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
-  $ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy))
+    where
-  $ fromIntegral radius
+      -- 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>

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" $
+    [ testProperty "one step in each cardinal direction is always visible"
-        let charPos = Position 20 20
+      $ \pos (Cardinal dir) (Positive r) (wallPositions :: Set Position)->
-            gormlakPos = Position 17 19
+          let em = review _EntityMap . map (, Wall) . toList $ wallPositions
-            em = insertAt gormlakPos TestEntity
+              em' = em & atPosition (move dir pos) %~ (Wall <|)
-               . insertAt charPos TestEntity
+              poss = visiblePositions pos r em'
-               $ mempty
+          in counterexample ("visiblePositions: " <> show poss)
-            visPositions = visiblePositions charPos 12 em
+             $ move dir pos `member` poss
-        in (gormlakPos `member` visPositions) @?
+    , testGroup "bugs"
-          ( "not ("
+      [ testCase "non-contiguous bug 1"
-          <> show gormlakPos <> " `member` "
+        $ let charPos = Position 20 20
-          <> show visPositions
+              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
+             <> ")"
+             )
+      ]
     ]
   ]
 

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"
-      $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12)
+      {-
-      @?= [ (1,12)
+        |   | 0 | 1 | 2 | 3 |
-          , (2,12)
+        |---+---+---+---+---|
-          , (3,12)
+        | 0 |   |   |   |   |
-          , (4,12)
+        | 1 |   |   | x |   |
-          , (5,12)
+        | 2 |   | x |   | x |
-          , (6,11)
+        | 3 |   |   | x |   |
-          , (7,10)
+      -}
-          , (7,11)
+      $ (sort . unique @[] @[_]) (circle @Int (2, 2) 1)
-          , (8,10)
+      @?= [ (1, 2)
-          , (9,9)
+          , (2, 1), (2, 3)
-          , (10,7)
+          , (3, 2)
-          , (10,8)
+          ]
-          , (11,6)
+    , testCase "radius 12, origin 0"
-          , (11,7)
+      $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12)
-          , (12,1)
+      @?= [ (-12,-4),(-12,-3),(-12,-2),(-12,-1),(-12,0),(-12,1),(-12,2)
-          , (12,2)
+          , (-12,3),(-12,4),(-11,-6),(-11,-5),(-11,5),(-11,6),(-10,-7),(-10,7)
-          , (12,3)
+          , (-9,-9),(-9,-8),(-9,8),(-9,9),(-8,-9),(-8,9),(-7,-10),(-7,10)
-          , (12,4)
+          , (-6,-11),(-6,11),(-5,-11),(-5 ,11),(-4,-12),(-4,12),(-3,-12),(-3,12)
-          , (12,5)
+          , (-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)
     ]
   ]
+
+--------------------------------------------------------------------------------