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:
parent
1351691136
commit
6f427fe4d6
5 changed files with 124 additions and 52 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
--
|
||||
|
|
|
@ -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"
|
||||
|
|
Loading…
Reference in a new issue