From 9b8d3185fe6cee9231ed20a1dbf0240d0c459a39 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Fri, 3 Jul 2020 20:32:36 -0400 Subject: 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 --- users/glittershark/xanthous/src/Xanthous/Data.hs | 18 ++-- .../src/Xanthous/Data/EntityMap/Graphics.hs | 2 +- .../xanthous/src/Xanthous/Generators.hs | 7 +- .../src/Xanthous/Generators/CaveAutomata.hs | 3 +- .../xanthous/src/Xanthous/Generators/Dungeon.hs | 9 +- .../src/Xanthous/Generators/LevelContents.hs | 21 +++-- .../xanthous/src/Xanthous/Generators/Util.hs | 96 +++++++++++----------- .../xanthous/src/Xanthous/Generators/Village.hs | 4 +- .../xanthous/src/Xanthous/Util/Graphics.hs | 84 ++++++++++--------- 9 files changed, 128 insertions(+), 116 deletions(-) (limited to 'users/glittershark/xanthous/src/Xanthous') diff --git a/users/glittershark/xanthous/src/Xanthous/Data.hs b/users/glittershark/xanthous/src/Xanthous/Data.hs index e2967d274fd5..c9c11b553b67 100644 --- a/users/glittershark/xanthous/src/Xanthous/Data.hs +++ b/users/glittershark/xanthous/src/Xanthous/Data.hs @@ -28,6 +28,7 @@ module Xanthous.Data , loc , _Position , positionFromPair + , positionFromV2 , addPositions , diffPositions , stepTowards @@ -176,7 +177,7 @@ instance Num a => Group (Position' a) where -- | Positions convert to scalars by discarding their orientation and just -- measuring the length from the origin instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where - scalar = fromIntegral . length . line (0, 0) . view _Position + scalar = fromIntegral . length . line 0 . view _Position fromScalar n = Position (fromScalar n) (fromScalar n) data Positioned a where @@ -220,15 +221,18 @@ loc = iso hither yon hither (Position px py) = Location (px, py) yon (Location (lx, ly)) = Position lx ly -_Position :: Iso' (Position' a) (a, a) +_Position :: Iso' (Position' a) (V2 a) _Position = iso hither yon where - hither (Position px py) = (px, py) - yon (lx, ly) = Position lx ly + hither (Position px py) = (V2 px py) + yon (V2 lx ly) = Position lx ly positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) +positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a +positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy) + -- | Add two positions -- -- Operation for the additive group on positions @@ -448,13 +452,13 @@ neighborDirections = Neighbors neighborPositions :: Num a => Position' a -> Neighbors (Position' a) neighborPositions pos = (`move` pos) <$> neighborDirections -neighborCells :: Num a => (a, a) -> Neighbors (a, a) +neighborCells :: Num a => V2 a -> Neighbors (V2 a) neighborCells = map (view _Position) . neighborPositions . review _Position arrayNeighbors :: (IArray a e, Ix i, Num i) - => a (i, i) e - -> (i, i) + => a (V2 i) e + -> V2 i -> Neighbors (Maybe e) arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) where diff --git a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs index 5a73bd393848..19e7b0cdf086 100644 --- a/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs @@ -44,7 +44,7 @@ linesOfSight (view _Position -> pos) visionRadius em lines = line pos <$> radius entitiesOnLines :: [[(Position, Vector (EntityID, e))]] entitiesOnLines = lines <&> map getPositionedAt - getPositionedAt :: (Int, Int) -> (Position, Vector (EntityID, e)) + getPositionedAt :: V2 Int -> (Position, Vector (EntityID, e)) getPositionedAt p = let ppos = _Position # p in (ppos, over _2 (view positioned) <$> atPositionWithIDs ppos em) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators.hs b/users/glittershark/xanthous/src/Xanthous/Generators.hs index 2801137b699c..ef37070b6ede 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators.hs @@ -39,6 +39,7 @@ import Xanthous.Entities.Environment import Xanthous.Entities.Item (Item) import Xanthous.Entities.Creature (Creature) import Xanthous.Game.State (SomeEntity(..)) +import Linear.V2 -------------------------------------------------------------------------------- data Generator @@ -91,18 +92,18 @@ parseGeneratorInput = Opt.subparser showCells :: Cells -> Text showCells arr = - let ((minX, minY), (maxX, maxY)) = bounds arr + let (V2 minX minY, V2 maxX maxY) = bounds arr showCellVal True = "x" showCellVal False = " " showCell = showCellVal . (arr !) - row r = foldMap (showCell . (, r)) [minX..maxX] + row r = foldMap (showCell . (`V2` r)) [minX..maxX] rows = row <$> [minY..maxY] in intercalate "\n" rows cellsToWalls :: Cells -> EntityMap Wall cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells where - maybeInsertWall em (pos@(x, y), True) + maybeInsertWall em (pos@(V2 x y), True) | not (surroundedOnAllSides pos) = let x' = fromIntegral x y' = fromIntegral y diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs index ada201ef3d6c..be904662f3f7 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs @@ -19,6 +19,7 @@ import Xanthous.Util (between) import Xanthous.Util.Optparse import Xanthous.Data (Dimensions, width, height) import Xanthous.Generators.Util +import Linear.V2 -------------------------------------------------------------------------------- data Params = Params @@ -102,7 +103,7 @@ generate' params dims = do stepAutomata :: forall s g. MCells s -> Dimensions -> Params -> CellM g s () stepAutomata cells dims params = do origCells <- lift $ cloneMArray @_ @(STUArray s) cells - for_ (range ((0, 0), (dims ^. width, dims ^. height))) $ \pos -> do + for_ (range (0, V2 (dims ^. width) (dims ^. height))) $ \pos -> do neighs <- lift $ numAliveNeighborsM origCells pos origValue <- lift $ readArray origCells pos lift . writeArray cells pos diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs index 7fde0075e64f..f30713ce1182 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs @@ -159,14 +159,14 @@ fillRoom cells room = V2 dimx dimy = room ^. dimensions in for_ [posx .. posx + dimx] $ \x -> for_ [posy .. posy + dimy] $ \y -> - lift $ writeArray cells (x, y) True + lift $ writeArray cells (V2 x y) True -corridorBetween :: MonadRandom m => Room -> Room -> m [(Word, Word)] +corridorBetween :: MonadRandom m => Room -> Room -> m [V2 Word] corridorBetween originRoom destinationRoom = straightLine <$> origin <*> destination where - origin = choose . NE.fromList . map toTuple =<< originEdge - destination = choose . NE.fromList . map toTuple =<< destinationEdge + origin = choose . NE.fromList =<< originEdge + destination = choose . NE.fromList =<< destinationEdge originEdge = pickEdge originRoom originCorner destinationEdge = pickEdge destinationRoom destinationCorner pickEdge room corner = choose . over both (boxEdge room) $ cornerEdges corner @@ -188,4 +188,3 @@ corridorBetween originRoom destinationRoom (EQ, EQ) -> TopLeft -- should never happen destinationCorner = opposite originCorner - toTuple (V2 x y) = (x, y) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs index ed4cc87e79d7..8ebcc7f4da83 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs @@ -14,13 +14,15 @@ import Control.Monad.Random import Data.Array.IArray (amap, bounds, rangeSize, (!)) import qualified Data.Array.IArray as Arr import Data.Foldable (any, toList) +import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Generators.Util import Xanthous.Random -import Xanthous.Data ( Position, _Position, positionFromPair - , rotations, arrayNeighbors, Neighbors(..) - , neighborPositions - ) +import Xanthous.Data + ( positionFromV2, Position, _Position + , rotations, arrayNeighbors, Neighbors(..) + , neighborPositions + ) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) import Xanthous.Entities.Raws (rawsWithType, RawType) import qualified Xanthous.Entities.Item as Item @@ -49,7 +51,7 @@ randomDoors cells = do doorRatio <- getRandomR subsetRange let numDoors = floor $ doorRatio * fromIntegral (length candidateCells) doorPositions = - removeAdjacent . fmap positionFromPair . take numDoors $ candidateCells + removeAdjacent . fmap positionFromV2 . take numDoors $ candidateCells doors = zip doorPositions $ repeat unlockedDoor pure $ _EntityMap # doors where @@ -92,8 +94,9 @@ tutorialMessage cells characterPosition = do accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] accessiblePositionsWithin dist valid pos = review _Position - <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py)) - (circle (pos ^. _Position) dist) + <$> filter + (\pt -> not $ valid ! (fromIntegral <$> pt)) + (circle (pos ^. _Position) dist) randomEntities :: forall entity raw m. (MonadRandom m, RawType raw) @@ -116,10 +119,10 @@ randomEntities newWithType sizeRange cells = pure $ _EntityMap # entities randomPosition :: MonadRandom m => Cells -> m Position -randomPosition = fmap positionFromPair . choose . impureNonNull . cellCandidates +randomPosition = fmap positionFromV2 . choose . impureNonNull . cellCandidates -- cellCandidates :: Cells -> Cells -cellCandidates :: Cells -> Set (Word, Word) +cellCandidates :: Cells -> Set (V2 Word) cellCandidates -- find the largest contiguous region of cells in the cave. = maximumBy (compare `on` length) diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs index e1e367007e65..88aadd5aadd9 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Util.hs @@ -20,6 +20,7 @@ module Xanthous.Generators.Util ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (Foldable, toList, for_) +-------------------------------------------------------------------------------- import Data.Array.ST import Data.Array.Unboxed import Control.Monad.ST @@ -28,13 +29,14 @@ import Data.Monoid import Data.Foldable (Foldable, toList, for_) import qualified Data.Set as Set import Data.Semigroup.Foldable +import Linear.V2 -------------------------------------------------------------------------------- import Xanthous.Util (foldlMapM', maximum1, minimum1) import Xanthous.Data (Dimensions, width, height) -------------------------------------------------------------------------------- -type MCells s = STUArray s (Word, Word) Bool -type Cells = UArray (Word, Word) Bool +type MCells s = STUArray s (V2 Word) Bool +type Cells = UArray (V2 Word) Bool type CellM g s a = RandT g (ST s) a randInitialize :: RandomGen g => Dimensions -> Double -> CellM g s (MCells s) @@ -43,28 +45,28 @@ randInitialize dims aliveChance = do for_ [0..dims ^. width] $ \i -> for_ [0..dims ^. height] $ \j -> do val <- (>= aliveChance) <$> getRandomR (0, 1) - lift $ writeArray res (i, j) val + lift $ writeArray res (V2 i j) val pure res initializeEmpty :: RandomGen g => Dimensions -> CellM g s (MCells s) initializeEmpty dims = - lift $ newArray ((0, 0), (dims ^. width, dims ^. height)) False + lift $ newArray (0, V2 (dims ^. width) (dims ^. height)) False numAliveNeighborsM - :: forall a i j m - . (MArray a Bool m, Ix (i, j), Integral i, Integral j) - => a (i, j) Bool - -> (i, j) + :: forall a i m + . (MArray a Bool m, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i -> m Word -numAliveNeighborsM cells (x, y) = do +numAliveNeighborsM cells (V2 x y) = do cellBounds <- getBounds cells getSum <$> foldlMapM' (fmap (Sum . fromIntegral . fromEnum) . boundedGet cellBounds) neighborPositions where - boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> m Bool - boundedGet ((minX, minY), (maxX, maxY)) (i, j) + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> m Bool + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) | x <= minX || y <= minY || x >= maxX @@ -73,23 +75,23 @@ numAliveNeighborsM cells (x, y) = do | otherwise = let nx = fromIntegral $ fromIntegral x + i ny = fromIntegral $ fromIntegral y + j - in readArray cells (nx, ny) + in readArray cells $ V2 nx ny numAliveNeighbors - :: forall a i j - . (IArray a Bool, Ix (i, j), Integral i, Integral j) - => a (i, j) Bool - -> (i, j) + :: forall a i + . (IArray a Bool, Ix i, Integral i) + => a (V2 i) Bool + -> V2 i -> Word -numAliveNeighbors cells (x, y) = +numAliveNeighbors cells (V2 x y) = let cellBounds = bounds cells in getSum $ foldMap (Sum . fromIntegral . fromEnum . boundedGet cellBounds) neighborPositions where - boundedGet :: ((i, j), (i, j)) -> (Int, Int) -> Bool - boundedGet ((minX, minY), (maxX, maxY)) (i, j) + boundedGet :: (V2 i, V2 i) -> (Int, Int) -> Bool + boundedGet (V2 minX minY, V2 maxX maxY) (i, j) | x <= minX || y <= minY || x >= maxX @@ -98,20 +100,20 @@ numAliveNeighbors cells (x, y) = | otherwise = let nx = fromIntegral $ fromIntegral x + i ny = fromIntegral $ fromIntegral y + j - in cells ! (nx, ny) + in cells ! V2 nx ny neighborPositions :: [(Int, Int)] neighborPositions = [(i, j) | i <- [-1..1], j <- [-1..1], (i, j) /= (0, 0)] -fillOuterEdgesM :: (MArray a Bool m, Ix i, Ix j) => a (i, j) Bool -> m () +fillOuterEdgesM :: (MArray a Bool m, Ix i) => a (V2 i) Bool -> m () fillOuterEdgesM arr = do - ((minX, minY), (maxX, maxY)) <- getBounds arr + (V2 minX minY, V2 maxX maxY) <- getBounds arr for_ (range (minX, maxX)) $ \x -> do - writeArray arr (x, minY) True - writeArray arr (x, maxY) True + writeArray arr (V2 x minY) True + writeArray arr (V2 x maxY) True for_ (range (minY, maxY)) $ \y -> do - writeArray arr (minX, y) True - writeArray arr (maxX, y) True + writeArray arr (V2 minX y) True + writeArray arr (V2 maxX y) True cloneMArray :: forall a a' i e m. @@ -128,20 +130,20 @@ cloneMArray = thaw @_ @UArray <=< freeze -- | Flood fill a cell array starting at a point, returning a list of all the -- (true) cell locations reachable from that point -floodFill :: forall a i j. +floodFill :: forall a i. ( IArray a Bool - , Ix (i, j) - , Enum i , Enum j - , Bounded i , Bounded j - , Eq i , Eq j + , Ix i + , Enum i + , Bounded i + , Eq i ) - => a (i, j) Bool -- ^ array - -> (i, j) -- ^ position - -> Set (i, j) + => a (V2 i) Bool -- ^ array + -> (V2 i) -- ^ position + -> Set (V2 i) floodFill = go mempty where - go :: Set (i, j) -> a (i, j) Bool -> (i, j) -> Set (i, j) - go res arr@(bounds -> arrBounds) idx@(x, y) + go :: Set (V2 i) -> a (V2 i) Bool -> (V2 i) -> Set (V2 i) + go res arr@(bounds -> arrBounds) idx@(V2 x y) | not (inRange arrBounds idx) = res | not (arr ! idx) = res | otherwise = @@ -149,7 +151,7 @@ floodFill = go mempty = filter (inRange arrBounds) . filter (/= idx) . filter (`notMember` res) - $ (,) + $ V2 <$> [(if x == minBound then x else pred x) .. (if x == maxBound then x else succ x)] @@ -162,19 +164,19 @@ floodFill = go mempty in r' `seq` go r' arr idx') else r) (res & contains idx .~ True) neighbors -{-# SPECIALIZE floodFill :: UArray (Word, Word) Bool -> (Word, Word) -> Set (Word, Word) #-} +{-# SPECIALIZE floodFill :: UArray (V2 Word) Bool -> (V2 Word) -> Set (V2 Word) #-} -- | Gives a list of all the disconnected regions in a cell array, represented -- each as lists of points -regions :: forall a i j. +regions :: forall a i. ( IArray a Bool - , Ix (i, j) - , Enum i , Enum j - , Bounded i , Bounded j - , Eq i , Eq j + , Ix i + , Enum i + , Bounded i + , Eq i ) - => a (i, j) Bool - -> [Set (i, j)] + => a (V2 i) Bool + -> [Set (V2 i)] regions arr | Just firstPoint <- findFirstPoint arr = let region = floodFill arr firstPoint @@ -182,9 +184,9 @@ regions arr in region : regions arr' | otherwise = [] where - findFirstPoint :: a (i, j) Bool -> Maybe (i, j) + findFirstPoint :: a (V2 i) Bool -> Maybe (V2 i) findFirstPoint = fmap fst . headMay . filter snd . assocs -{-# SPECIALIZE regions :: UArray (Word, Word) Bool -> [Set (Word, Word)] #-} +{-# SPECIALIZE regions :: UArray (V2 Word) Bool -> [Set (V2 Word)] #-} fillAll :: (IArray a Bool, Ix i, Foldable f) => f i -> a i Bool -> a i Bool fillAll ixes a = accum (const fst) a $ (, (False, ())) <$> toList ixes diff --git a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs index 614170d0c4f1..cc9c9d963f5c 100644 --- a/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs +++ b/users/glittershark/xanthous/src/Xanthous/Generators/Village.hs @@ -73,9 +73,9 @@ fromCave' wallPositions = failing (pure ()) $ do where insertEntity e pt = modify $ EntityMap.insertAt (ptToPos pt) $ SomeEntity e - ptToPos pt = _Position # (pt & both %~ fromIntegral) + ptToPos pt = _Position # (fromIntegral <$> pt) - stepOut :: Set (Word, Word) -> [[(Word, Word)]] -> MaybeT m [[(Word, Word)]] + stepOut :: Set (V2 Word) -> [[V2 Word]] -> MaybeT m [[V2 Word]] stepOut circ rooms = for rooms $ \room -> let nextLevels = hashNub $ toList . neighborCells =<< room in pure 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 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 -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) + ) -- cgit 1.4.1