Use open circles to generate filled circles

Rather than leaning on rasterific to generate filled circles for us,
instead start with an open circle, then fill it by scanning line-by-line
and filling in points that are "inside" of the circle, based on keeping
track with a boolean. Also adds a couple of helper functions for
displaying these kinda "boolean graphics" things we're passing around,
as sets of points.

2 files changed, 81 insertions, 43 deletions

diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs
index ea1dbffe839b..5f7432f4c7e2 100644
--- a/src/Xanthous/Util/Graphics.hs
+++ b/src/Xanthous/Util/Graphics.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TemplateHaskell #-}
 -- | Graphics algorithms and utils for rendering things in 2D space
 --------------------------------------------------------------------------------
 module Xanthous.Util.Graphics
@@ -6,6 +7,10 @@ module Xanthous.Util.Graphics
   , line
   , straightLine
   , delaunay
+
+    -- * Debugging and testing tools
+  , renderBooleanGraphics
+  , showBooleanGraphics
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
@@ -16,16 +21,13 @@ import           Xanthous.Prelude
 import qualified Algorithms.Geometry.DelaunayTriangulation.Naive
               as Geometry
 import qualified Algorithms.Geometry.DelaunayTriangulation.Types as Geometry
-import           Codec.Picture (imagePixels)
+import           Control.Monad.State (execState, State)
 import qualified Data.Geometry.Point as Geometry
 import           Data.Ext ((:+)(..))
 import           Data.List (unfoldr)
-import           Data.List.NonEmpty (NonEmpty)
-import           Data.Ix (range, Ix)
-import           Data.Word (Word8)
-import qualified Graphics.Rasterific as Raster
-import           Graphics.Rasterific hiding (circle, line, V2(..))
-import           Graphics.Rasterific.Texture (uniformTexture)
+import           Data.List.NonEmpty (NonEmpty((:|)))
+import qualified Data.List.NonEmpty as NE
+import           Data.Ix (Ix)
 import           Linear.V2
 --------------------------------------------------------------------------------
 
@@ -65,41 +67,44 @@ circle (x₀, y₀) radius
           x' = x + 1
 
 
+data FillState i
+  = FillState
+  { _inCircle :: Bool
+  , _result :: NonEmpty (i, i)
+  }
+makeLenses ''FillState
+
+runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)]
+runFillState circumference s
+  = toList
+  . view result
+  . execState s
+  $ FillState False circumference
+
 -- | 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!)
+-- radius by filling a circle generated with 'circle'
 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 (Raster.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
+filledCircle origin radius =
+  case NE.nonEmpty (circle origin radius) of
+    Nothing -> []
+    Just circumference -> runFillState circumference $
+      -- the first and last lines of all circles are solid, so the whole "in the
+      -- circle, out of the circle" thing doesn't work... but that's fine since
+      -- we don't need to fill them. So just skip them
+      for_ [succ minX..pred maxX] $ \x ->
+        for_ [minY..maxY] $ \y -> do
+          let pt = (x, y)
+              next = (x, succ y)
+          whenM (use inCircle) $ result %= NE.cons pt
+
+          when (pt `elem` circumference && next `notElem` circumference)
+            $ inCircle %= not
+
+      where
+        ((minX, minY), (maxX, maxY)) = minmaxes circumference
 
 -- | Draw a line between two points using Bresenham's line drawing algorithm
 --
@@ -141,3 +146,29 @@ delaunay
   where
     toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
     fromPoint (Geometry.Point2 px py :+ pid) = (V2 px py, pid)
+
+--------------------------------------------------------------------------------
+
+renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String
+renderBooleanGraphics [] = ""
+renderBooleanGraphics (pt : pts') = intercalate "\n" rows
+  where
+    rows = row <$> [minX..maxX]
+    row x = [minY..maxY] <&> \y -> if (x, y) `member` ptSet then 'X' else ' '
+    ((minX, minY), (maxX, maxY)) = minmaxes pts
+    pts = pt :| pts'
+    ptSet :: Set (i, i)
+    ptSet = setFromList $ toList pts
+
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO ()
+showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
+
+minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i))
+minmaxes xs =
+    ( ( minimum1Of (traverse1 . _1) xs
+      , minimum1Of (traverse1 . _2) xs
+      )
+    , ( maximum1Of (traverse1 . _1) xs
+      , maximum1Of (traverse1 . _2) xs
+      )
+    )
diff --git a/test/Xanthous/Util/GraphicsSpec.hs b/test/Xanthous/Util/GraphicsSpec.hs
index a1eaf73e2845..ff99d1073840 100644
--- a/test/Xanthous/Util/GraphicsSpec.hs
+++ b/test/Xanthous/Util/GraphicsSpec.hs
@@ -5,6 +5,7 @@ import Test.Prelude hiding (head)
 import Xanthous.Util.Graphics
 import Xanthous.Util
 import Data.List (head)
+import Data.Set (isSubsetOf)
 --------------------------------------------------------------------------------
 
 main :: IO ()
@@ -40,12 +41,18 @@ test = testGroup "Xanthous.Util.Graphics"
           , (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 "filledCircle"
+    [ testProperty "is a superset of circle" $ \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
+    -- TODO later
+    -- , testProperty "is always contiguous" $ \center radius ->
+    --     let filledCirc = filledCircle center radius
+    --     in counterexample (renderBooleanGraphics filledCirc) $
     ]
   , testGroup "line"
     [ testProperty "starts and ends at the start and end points" $ \start end ->