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.

2 files changed, 56 insertions, 34 deletions

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)
     ]
   ]
+
+--------------------------------------------------------------------------------