about summary refs log tree commit diff
path: root/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
diff options
context:
space:
mode:
authorGriffin Smith <grfn@gws.fyi>2020-07-04T00·32-0400
committerglittershark <grfn@gws.fyi>2020-07-04T15·30+0000
commit9b8d3185fe6cee9231ed20a1dbf0240d0c459a39 (patch)
tree29b8f78a81500043df1fa8ca289bdb2a35dc68ff /users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
parent4455f28e426f49c2e3b8ef08961e5073a11a5b4f (diff)
refactor(xan): Switch to V2 over tuples most places r/1207
These are generally rather nicer to work due to some typeclass instances,
and integrate better with other ecosystems for things like linear
algebra etc.

Change-Id: I546c8da7b17234648f3d612b28741c1fded25447
Reviewed-on: https://cl.tvl.fyi/c/depot/+/910
Tested-by: BuildkiteCI
Reviewed-by: glittershark <grfn@gws.fyi>
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs')
-rw-r--r--users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs84
1 files changed, 43 insertions, 41 deletions
diff --git a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
index 1b8b79164397..353fcfc59b14 100644
--- a/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
+++ b/users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
@@ -38,18 +38,22 @@ import           Linear.V2
 --
 -- Code taken from <https://rosettacode.org/wiki/Bitmap/Midpoint_circle_algorithm#Haskell>
 circle :: (Num i, Ord i)
-       => (i, i) -- ^ center
-       -> i      -- ^ radius
-       -> [(i, i)]
-circle (x₀, y₀) radius
+       => V2 i -- ^ center
+       -> i    -- ^ radius
+       -> [V2 i]
+circle (V2 x₀ y₀) radius
   -- Four initial points, plus the generated points
-  = (x₀, y₀ + radius) : (x₀, y₀ - radius) : (x₀ + radius, y₀) : (x₀ - radius, y₀) : points
+  = V2 x₀ (y₀ + radius)
+  : V2 x₀ (y₀ - radius)
+  : V2 (x₀ + radius) y₀
+  : V2 (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
 
-      generatePoints (x, y)
-        = [ (x₀ `xop` x', y₀ `yop` y')
+      generatePoints (V2 x y)
+        = [ V2 (x₀ `xop` x') (y₀ `yop` y')
           | (x', y') <- [(x, y), (y, x)]
           , xop <- [(+), (-)]
           , yop <- [(+), (-)]
@@ -59,7 +63,7 @@ circle (x₀, y₀) radius
 
       step (f, ddf_x, ddf_y, x, y)
         | x >= y = Nothing
-        | otherwise = Just ((x', y'), (f', ddf_x', ddf_y', x', y'))
+        | otherwise = Just (V2 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)
@@ -70,11 +74,11 @@ circle (x₀, y₀) radius
 data FillState i
   = FillState
   { _inCircle :: Bool
-  , _result :: NonEmpty (i, i)
+  , _result :: NonEmpty (V2 i)
   }
 makeLenses ''FillState
 
-runFillState :: NonEmpty (i, i) -> State (FillState i) a -> [(i, i)]
+runFillState :: NonEmpty (V2 i) -> State (FillState i) a -> [V2 i]
 runFillState circumference s
   = toList
   . view result
@@ -84,11 +88,11 @@ runFillState circumference s
 -- | Generate a *filled* circle centered at the given point and with the given
 -- radius by filling a circle generated with 'circle'
 filledCircle :: (Num i, Integral i, Ix i)
-             => (i, i) -- ^ center
-             -> i      -- ^ radius
-             -> [(i, i)]
-filledCircle origin radius =
-  case NE.nonEmpty (circle origin radius) of
+             => V2 i -- ^ center
+             -> i    -- ^ radius
+             -> [V2 i]
+filledCircle center radius =
+  case NE.nonEmpty (circle center radius) of
     Nothing -> []
     Just circumference -> runFillState circumference $
       -- the first and last lines of all circles are solid, so the whole "in the
@@ -96,44 +100,44 @@ filledCircle origin radius =
       -- 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)
+          let pt = V2 x y
+              next = V2 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
+        (V2 minX minY, V2 maxX maxY) = minmaxes circumference
 
 -- | Draw a line between two points using Bresenham's line drawing algorithm
 --
 -- Code taken from <https://wiki.haskell.org/Bresenham%27s_line_drawing_algorithm>
-line :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
-line pa@(xa, ya) pb@(xb, yb)
+line :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i]
+line pa@(V2 xa ya) pb@(V2 xb yb)
   = (if maySwitch pa < maySwitch pb then id else reverse) points
   where
     points               = map maySwitch . unfoldr go $ (x₁, y₁, 0)
     steep                = abs (yb - ya) > abs (xb - xa)
-    maySwitch            = if steep then swap else id
-    [(x₁, y₁), (x₂, y₂)] = sort [maySwitch pa, maySwitch pb]
+    maySwitch            = if steep then view _yx else id
+    [V2 x₁ y₁, V2 x₂ y₂] = sort [maySwitch pa, maySwitch pb]
     δx                   = x₂ - x₁
     δy                   = abs (y₂ - y₁)
     ystep                = if y₁ < y₂ then 1 else -1
     go (xTemp, yTemp, err)
       | xTemp > x₂ = Nothing
-      | otherwise  = Just ((xTemp, yTemp), (xTemp + 1, newY, newError))
+      | otherwise  = Just ((V2 xTemp yTemp), (xTemp + 1, newY, newError))
       where
         tempError        = err + δy
         (newY, newError) = if (2 * tempError) >= δx
                            then (yTemp + ystep, tempError - δx)
                            else (yTemp, tempError)
-{-# SPECIALIZE line :: (Int, Int) -> (Int, Int) -> [(Int, Int)] #-}
-{-# SPECIALIZE line :: (Word, Word) -> (Word, Word) -> [(Word, Word)] #-}
+{-# SPECIALIZE line :: V2 Int -> V2 Int -> [V2 Int] #-}
+{-# SPECIALIZE line :: V2 Word -> V2 Word -> [V2 Word] #-}
 
-straightLine :: (Num i, Ord i) => (i, i) -> (i, i) -> [(i, i)]
-straightLine pa@(xa, _) pb@(_, yb) = line pa midpoint ++ line midpoint pb
-  where midpoint = (xa, yb)
+straightLine :: (Num i, Ord i) => V2 i -> V2 i -> [V2 i]
+straightLine pa@(V2 xa _) pb@(V2 _ yb) = line pa midpoint ++ line midpoint pb
+  where midpoint = V2 xa yb
 
 
 delaunay
@@ -151,26 +155,24 @@ delaunay
 
 --------------------------------------------------------------------------------
 
-renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> String
+renderBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 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
+    row x = [minY..maxY] <&> \y -> if V2 x y `member` ptSet then 'X' else ' '
+    (V2 minX minY, V2 maxX maxY) = minmaxes pts
     pts = pt :| pts'
-    ptSet :: Set (i, i)
+    ptSet :: Set (V2 i)
     ptSet = setFromList $ toList pts
 
-showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [(i, i)] -> IO ()
+showBooleanGraphics :: forall i. (Num i, Ord i, Enum i) => [V2 i] -> IO ()
 showBooleanGraphics = putStrLn . pack . renderBooleanGraphics
 
-minmaxes :: forall i. (Ord i) => NonEmpty (i, i) -> ((i, i), (i, i))
+minmaxes :: forall i. (Ord i) => NonEmpty (V2 i) -> (V2 i, V2 i)
 minmaxes xs =
-    ( ( minimum1Of (traverse1 . _1) xs
-      , minimum1Of (traverse1 . _2) xs
-      )
-    , ( maximum1Of (traverse1 . _1) xs
-      , maximum1Of (traverse1 . _2) xs
-      )
-    )
+  ( V2 (minimum1Of (traverse1 . _x) xs)
+       (minimum1Of (traverse1 . _y) xs)
+  , V2 (maximum1Of (traverse1 . _x) xs)
+       (maximum1Of (traverse1 . _y) xs)
+  )