Fix circle rendering, add filled circle

Make raster circle rendering use the Rasterific package instead of
attempting desperately to hand-roll it, and add a method for generating
filled circles.

package.yaml

@@ -36,6 +36,7 @@ dependencies:
 - generic-monoid
 - generic-lens
 - groups
+- JuicyPixels
 - lens
 - megaparsec
 - MonadRandom
@@ -47,7 +48,9 @@ dependencies:
 - random-source
 - raw-strings-qq
 - reflection
+- Rasterific
 - stache
+- semigroupoids
 - tomland
 - text-zipper
 - vector

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

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

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

test/Xanthous/Util/GraphicsSpec.hs

@@ -15,19 +15,26 @@ test = testGroup "Xanthous.Util.Graphics"
   [ testGroup "circle"
     [ testCase "radius 12, origin 0"
       $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12)
-      @?= (sort . unique) (
-        let quadrant =
-              [ (0, 12) , (1, 12) , (2, 12) , (3, 12)
-              , (4, 12) , (5, 11) , (6, 11) , (7, 10)
-              , (8, 9)  , (9, 9)  , (9, 8)  , (10, 7)
-              , (11, 6) , (11, 5) , (12, 4) , (12, 3)
-              , (12, 2) , (12, 1) , (12, 0)
-              ]
-        in  quadrant
-         <> (quadrant <&> _1 %~ negate)
-         <> (quadrant <&> _2 %~ negate)
-         <> (quadrant <&> both %~ negate)
-      )
+      @?= [ (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)
+          ]
     ]
 
   , testGroup "line"