about summary refs log tree commit diff
path: root/src/Xanthous/Util/Graphics.hs
diff options
context:
space:
mode:
authorGriffin Smith <root@gws.fyi>2019-12-25T00·40-0500
committerGriffin Smith <root@gws.fyi>2019-12-30T16·24-0500
commit6f427fe4d6ba9a03f122d15839298040a7cfb925 (patch)
tree5ab6c11d7b1f4109e1d196f9d1135cbb4bd828f6 /src/Xanthous/Util/Graphics.hs
parent13516911366a484ee5484166520133e056010515 (diff)
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.
Diffstat (limited to 'src/Xanthous/Util/Graphics.hs')
-rw-r--r--src/Xanthous/Util/Graphics.hs81
1 files changed, 51 insertions, 30 deletions
diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs
index 3dc2f6f14cac..e8269e72d6c8 100644
--- a/src/Xanthous/Util/Graphics.hs
+++ b/src/Xanthous/Util/Graphics.hs
@@ -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           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
-    where
-      -- Creates the (x, y) octet offsets, then maps them to absolute points in all octets.
-      points = concatMap generatePoints $ unfoldr step initialValues
+circle (ox, oy) radius
+  = pointsFromRaster (ox + radius) (oy + radius)
+  $ stroke 1 JoinRound (CapRound, CapRound)
+  $ Raster.circle (V2 (fromIntegral ox) (fromIntegral oy))
+  $ fromIntegral radius
 
-      generatePoints (x, y)
-        = [ (x₀ `xop` x', y₀ `yop` y')
-          | (x', y') <- [(x, y), (y, x)]
-          , xop <- [(+), (-)]
-          , yop <- [(+), (-)]
-          ]
+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
+    pixels = toListOf imagePixels
+           $ renderDrawing @Word8 (fromIntegral w) (fromIntegral h) 0
+           $ withTexture (uniformTexture 1) raster
 
-      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
 --