diff options
| -rw-r--r-- | src/Xanthous/Util/Graphics.hs | 105 | ||||
| -rw-r--r-- | test/Xanthous/Util/GraphicsSpec.hs | 19 |
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 -> |