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.
This commit is contained in:
Griffin Smith 2019-12-24 19:40:52 -05:00
parent 1351691136
commit 6f427fe4d6
5 changed files with 124 additions and 52 deletions

View file

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

View file

@ -1,4 +1,6 @@
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
--------------------------------------------------------------------------------
module Xanthous.Generators.Util
( MCells
@ -13,6 +15,8 @@ module Xanthous.Generators.Util
, regions
, fillAll
, fillAllM
, fromPoints
, fromPointsM
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude hiding (Foldable, toList, for_)
@ -22,8 +26,10 @@ 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.Util (foldlMapM', maximum1, minimum1)
import Xanthous.Data (Dimensions, width, height)
--------------------------------------------------------------------------------
@ -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

View file

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

View file

@ -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 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
circle (ox, oy) radius
= pointsFromRaster (ox + radius) (oy + radius)
$ stroke 1 JoinRound (CapRound, CapRound)
$ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
$ fromIntegral radius
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
-- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
points = concatMap generatePoints $ unfoldr step initialValues
pixels = toListOf imagePixels
$ renderDrawing @Word8 (fromIntegral w) (fromIntegral h) 0
$ withTexture (uniformTexture 1) raster
generatePoints (x, y)
= [ (x `xop` x', y `yop` y')
| (x', y') <- [(x, y), (y, x)]
, xop <- [(+), (-)]
, yop <- [(+), (-)]
]
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
--

View file

@ -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)
@?= [ (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)
]
in quadrant
<> (quadrant <&> _1 %~ negate)
<> (quadrant <&> _2 %~ negate)
<> (quadrant <&> both %~ negate)
)
]
, testGroup "line"