3 files changed, 101 insertions, 39 deletions
diff --git a/src/Xanthous/Generators/Util.hs b/src/Xanthous/Generators/Util.hs
index 8fd04c0b9326..2c041149d900 100644
--- a/src/Xanthous/Generators/Util.hs
+++ b/src/Xanthous/Generators/Util.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
 --------------------------------------------------------------------------------
 module Xanthous.Generators.Util
   ( MCells
@@ -13,18 +15,22 @@ module Xanthous.Generators.Util
   , regions
   , fillAll
   , fillAllM
+  , fromPoints
+  , fromPointsM
   ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude hiding (Foldable, toList, for_)
-import Data.Array.ST
-import Data.Array.Unboxed
-import Control.Monad.ST
-import Control.Monad.Random
-import Data.Monoid
-import Data.Foldable (Foldable, toList, for_)
+import           Xanthous.Prelude hiding (Foldable, toList, for_)
+import           Data.Array.ST
+import           Data.Array.Unboxed
+import           Control.Monad.ST
+import           Control.Monad.Random
+import           Data.Monoid
+import           Data.Foldable (Foldable, toList, for_)
+import qualified Data.Set as Set
+import           Data.Semigroup.Foldable
 --------------------------------------------------------------------------------
-import Xanthous.Util (foldlMapM')
-import Xanthous.Data (Dimensions, width, height)
+import           Xanthous.Util (foldlMapM', maximum1, minimum1)
+import           Xanthous.Data (Dimensions, width, height)
 --------------------------------------------------------------------------------
 
 type MCells s = STUArray s (Word, Word) Bool
@@ -184,3 +190,28 @@ fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes
 
 fillAllM :: (MArray a Bool m, Ix i, Foldable f) => f i -> a i Bool -> m ()
 fillAllM ixes a = for_ ixes $ \i -> writeArray a i False
+
+fromPoints
+  :: forall a f i.
+    ( IArray a Bool
+    , Ix i
+    , Functor f
+    , Foldable1 f
+    )
+  => f (i, i)
+  -> a (i, i) Bool
+fromPoints points =
+  let pts = Set.fromList $ toList points
+      dims = ( (minimum1 $ fst <$> points, minimum1 $ snd <$> points)
+             , (maximum1 $ fst <$> points, maximum1 $ snd <$> points)
+             )
+  in array dims $ range dims <&> \i -> (i, i `member` pts)
+
+fromPointsM
+  :: (MArray a Bool m, Ix i, Element f ~ i, MonoFoldable f)
+  => NonNull f
+  -> m (a i Bool)
+fromPointsM points = do
+  arr <- newArray (minimum points, maximum points) False
+  fillAllM (otoList points) arr
+  pure arr
diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs
index b8b789e1b1ea..93155af3fd59 100644
--- a/src/Xanthous/Util.hs
+++ b/src/Xanthous/Util.hs
@@ -26,6 +26,8 @@ module Xanthous.Util
   , takeWhileInclusive
   , smallestNotIn
   , removeVectorIndex
+  , maximum1
+  , minimum1
 
     -- * Type-level programming utils
   , KnownBool(..)
@@ -38,6 +40,8 @@ import           Data.Foldable (foldr)
 import           Data.Monoid
 import           Data.Proxy
 import qualified Data.Vector as V
+import           Data.Semigroup (Max(..), Min(..))
+import           Data.Semigroup.Foldable
 --------------------------------------------------------------------------------
 
 newtype EqEqProp a = EqEqProp a
@@ -218,6 +222,12 @@ removeVectorIndex idx vect =
   let (before, after) = V.splitAt idx vect
   in before <> fromMaybe Empty (tailMay after)
 
+maximum1 :: (Ord a, Foldable1 f) => f a -> a
+maximum1 = getMax . foldMap1 Max
+
+minimum1 :: (Ord a, Foldable1 f) => f a -> a
+minimum1 = getMin . foldMap1 Min
+
 --------------------------------------------------------------------------------
 
 -- | This class gives a boolean associated with a type-level bool, a'la
diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs
index 3dc2f6f14cac..e8269e72d6c8 100644
--- a/src/Xanthous/Util/Graphics.hs
+++ b/src/Xanthous/Util/Graphics.hs
@@ -1,44 +1,65 @@
 -- | Graphics algorithms and utils for rendering things in 2D space
 --------------------------------------------------------------------------------
-module Xanthous.Util.Graphics where
+module Xanthous.Util.Graphics
+  ( circle
+  , filledCircle
+  , line
+  ) where
 --------------------------------------------------------------------------------
-import Xanthous.Prelude
-import Data.List (unfoldr)
+import           Xanthous.Prelude
+import           Data.List (unfoldr)
+import           Data.Ix (range, Ix)
+import           Data.Word (Word8)
+import qualified Graphics.Rasterific as Raster
+import           Graphics.Rasterific hiding (circle, line)
+import           Graphics.Rasterific.Texture (uniformTexture)
+import           Codec.Picture (imagePixels)
 --------------------------------------------------------------------------------
 
--- | 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)
+
+circle :: (Num i, Integral i, Ix i)
        => (i, i) -- ^ center
        -> i      -- ^ radius
        -> [(i, i)]
-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
+circle (ox, oy) radius
+  = pointsFromRaster (ox + radius) (oy + radius)
+  $ stroke 1 JoinRound (CapRound, CapRound)
+  $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
+  $ fromIntegral radius
 
-      generatePoints (x, y)
-        = [ (x₀ `xop` x', y₀ `yop` y')
-          | (x', y') <- [(x, y), (y, x)]
-          , xop <- [(+), (-)]
-          , yop <- [(+), (-)]
-          ]
+filledCircle :: (Num i, Integral i, Ix i)
+             => (i, i) -- ^ center
+             -> i      -- ^ radius
+             -> [(i, i)]
+filledCircle (ox, oy) radius
+  = pointsFromRaster (ox + radius) (oy + radius)
+  $ fill
+  $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
+  $ fromIntegral radius
+
+-- showCells . fromPoints . NE.fromList $ filledCircle (15, 15) 7
+-- pointsFromRaster :: (Num i, Integral i, Ix i)
+--                  => i      -- ^ width
+--                  -> i      -- ^ height
+--                  -> _
+--                  -> [(i, i)]
+pointsFromRaster
+  :: (Integral a, Integral b, Ix a, Ix b)
+  => a
+  -> b
+  -> Drawing Word8 ()
+  -> [(a, b)]
+pointsFromRaster w h raster
+  = map snd
+  $ filter ((== 1) . fst)
+  $ zip pixels
+  $ range ((1, 1), (w, h))
+  where
+    pixels = toListOf imagePixels
+           $ renderDrawing @Word8 (fromIntegral w) (fromIntegral h) 0
+           $ withTexture (uniformTexture 1) raster
 
-      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
 
 -- | Draw a line between two points using Bresenham's line drawing algorithm
 --