3 files changed, 61 insertions, 17 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>