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:
parent
78a323ec7a
commit
2320cfa8cd
2 changed files with 80 additions and 42 deletions
|
@ -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
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
|
@ -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 ->
|
||||||
|
|
Loading…
Reference in a new issue