diff options
Diffstat (limited to 'users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs')
| -rw-r--r-- | users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs | 84 |
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 1b8b791643..353fcfc59b 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) + ) |