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.
This commit is contained in:
Griffin Smith 2020-05-10 19:44:30 -04:00
parent 78a323ec7a
commit 2320cfa8cd
2 changed files with 80 additions and 42 deletions

View file

@ -1,3 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
-- | Graphics algorithms and utils for rendering things in 2D space -- | Graphics algorithms and utils for rendering things in 2D space
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Util.Graphics module Xanthous.Util.Graphics
@ -6,6 +7,10 @@ module Xanthous.Util.Graphics
, line , line
, straightLine , straightLine
, delaunay , delaunay
-- * Debugging and testing tools
, renderBooleanGraphics
, showBooleanGraphics
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
@ -16,16 +21,13 @@ import Xanthous.Prelude
import qualified Algorithms.Geometry.DelaunayTriangulation.Naive import qualified Algorithms.Geometry.DelaunayTriangulation.Naive
as Geometry as Geometry
import qualified Algorithms.Geometry.DelaunayTriangulation.Types 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 qualified Data.Geometry.Point as Geometry
import Data.Ext ((:+)(..)) import Data.Ext ((:+)(..))
import Data.List (unfoldr) import Data.List (unfoldr)
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Ix (range, Ix) import qualified Data.List.NonEmpty as NE
import Data.Word (Word8) import Data.Ix (Ix)
import qualified Graphics.Rasterific as Raster
import Graphics.Rasterific hiding (circle, line, V2(..))
import Graphics.Rasterific.Texture (uniformTexture)
import Linear.V2 import Linear.V2
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -65,41 +67,44 @@ circle (x₀, y₀) radius
x' = x + 1 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 -- | 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 -- radius by filling a circle generated with 'circle'
-- 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) filledCircle :: (Num i, Integral i, Ix i)
=> (i, i) -- ^ center => (i, i) -- ^ center
-> i -- ^ radius -> i -- ^ radius
-> [(i, i)] -> [(i, i)]
filledCircle (ox, oy) radius filledCircle origin radius =
= pointsFromRaster (ox + radius) (oy + radius) case NE.nonEmpty (circle origin radius) of
$ fill Nothing -> []
$ Raster.circle (Raster.V2 (fromIntegral ox) (fromIntegral oy)) Just circumference -> runFillState circumference $
$ fromIntegral radius -- 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
-- showCells . fromPoints . NE.fromList $ filledCircle (15, 15) 7 when (pt `elem` circumference && next `notElem` circumference)
-- pointsFromRaster :: (Num i, Integral i, Ix i) $ inCircle %= not
-- => i -- ^ width
-- -> i -- ^ height where
-- -> _ ((minX, minY), (maxX, maxY)) = minmaxes circumference
-- -> [(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
-- | Draw a line between two points using Bresenham's line drawing algorithm -- | Draw a line between two points using Bresenham's line drawing algorithm
-- --
@ -141,3 +146,29 @@ delaunay
where where
toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid toPoint (V2 px py, pid) = Geometry.Point2 px py :+ pid
fromPoint (Geometry.Point2 px py :+ pid) = (V2 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
)
)

View file

@ -5,6 +5,7 @@ import Test.Prelude hiding (head)
import Xanthous.Util.Graphics import Xanthous.Util.Graphics
import Xanthous.Util import Xanthous.Util
import Data.List (head) import Data.List (head)
import Data.Set (isSubsetOf)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
main :: IO () main :: IO ()
@ -40,12 +41,18 @@ test = testGroup "Xanthous.Util.Graphics"
, (12,0), (12,1),(12,2),(12,3),(12,4) , (12,0), (12,1),(12,2),(12,3),(12,4)
] ]
-- , testProperty "is a subset of filledCircle" $ \center radius -> ]
-- let circ = circle @Int center radius , testGroup "filledCircle"
-- filledCirc = filledCircle center radius [ testProperty "is a superset of circle" $ \center radius ->
-- in counterexample ( "circle: " <> show circ let circ = circle @Int center radius
-- <> "\nfilledCircle: " <> show filledCirc) filledCirc = filledCircle center radius
-- $ setFromList circ `isSubsetOf` setFromList filledCirc 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" , testGroup "line"
[ testProperty "starts and ends at the start and end points" $ \start end -> [ testProperty "starts and ends at the start and end points" $ \start end ->