refactor(xan): Switch to V2 over tuples most places
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>
This commit is contained in:
Griffin Smith
glittershark
parent
4455f28e42
commit
9b8d3185fe
12 changed files with 172 additions and 143 deletions
|
|
@ -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)
|
||||
)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue