diff options
Diffstat (limited to 'users/glittershark')
12 files changed, 172 insertions, 143 deletions
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 <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) + ) diff --git a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs b/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs index c82c385987b5..cdfadc06f505 100644 --- a/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs +++ b/users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE PackageImports #-} - +-------------------------------------------------------------------------------- module Xanthous.Generators.UtilSpec (main, test) where - +-------------------------------------------------------------------------------- import Test.Prelude import System.Random (mkStdGen) import Control.Monad.Random (runRandT) @@ -11,18 +11,23 @@ import Data.Array.MArray (newArray, readArray, writeArray) import Data.Array (Array, range, listArray, Ix) import Control.Monad.ST (ST, runST) import "checkers" Test.QuickCheck.Instances.Array () - +import Linear.V2 +-------------------------------------------------------------------------------- import Xanthous.Util import Xanthous.Data (width, height) import Xanthous.Generators.Util +-------------------------------------------------------------------------------- main :: IO () main = defaultMain test +-------------------------------------------------------------------------------- + newtype GenArray a b = GenArray (Array a b) deriving stock (Show, Eq) -instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) => Arbitrary (GenArray a b) where +instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) + => Arbitrary (GenArray a b) where arbitrary = GenArray <$> do (mkElem :: a -> b) <- arbitrary minDims <- arbitrary @@ -33,16 +38,18 @@ instance (Ix a, Arbitrary a, CoArbitrary a, Arbitrary b) => Arbitrary (GenArray test :: TestTree test = testGroup "Xanthous.Generators.Util" [ testGroup "randInitialize" - [ testProperty "returns an array of the correct dimensions" $ \dims seed aliveChance -> + [ testProperty "returns an array of the correct dimensions" + $ \dims seed aliveChance -> let gen = mkStdGen seed res = runSTUArray $ fmap fst $ flip runRandT gen $ randInitialize dims aliveChance - in bounds res === ((0, 0), (dims ^. width, dims ^. height)) + in bounds res === (0, V2 (dims ^. width) (dims ^. height)) ] , testGroup "numAliveNeighborsM" - [ testProperty "maxes out at 8" $ \(GenArray (arr :: Array (Word, Word) Bool)) loc -> + [ testProperty "maxes out at 8" + $ \(GenArray (arr :: Array (V2 Word) Bool)) loc -> let act :: forall s. ST s Word act = do @@ -53,7 +60,7 @@ test = testGroup "Xanthous.Generators.Util" ] , testGroup "numAliveNeighbors" [ testProperty "is equivalient to runST . numAliveNeighborsM . thaw" $ - \(GenArray (arr :: Array (Word, Word) Bool)) loc -> + \(GenArray (arr :: Array (V2 Word) Bool)) loc -> let act :: forall s. ST s Word act = do diff --git a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs b/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs index ff99d1073840..61e589280362 100644 --- a/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs +++ b/users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs @@ -2,10 +2,13 @@ module Xanthous.Util.GraphicsSpec (main, test) where -------------------------------------------------------------------------------- import Test.Prelude hiding (head) -------------------------------------------------------------------------------- +import Data.List (nub, head) +import Data.Set (isSubsetOf) +import Linear.V2 +-------------------------------------------------------------------------------- import Xanthous.Util.Graphics import Xanthous.Util -import Data.List (head) -import Data.Set (isSubsetOf) +import Xanthous.Orphans () -------------------------------------------------------------------------------- main :: IO () @@ -23,24 +26,28 @@ test = testGroup "Xanthous.Util.Graphics" | 2 | | x | | x | | 3 | | | x | | -} - $ (sort . unique @[] @[_]) (circle @Int (2, 2) 1) - @?= [ (1, 2) - , (2, 1), (2, 3) - , (3, 2) + $ (sort . unique @[] @[_]) (circle @Int (V2 2 2) 1) + @?= [ V2 1 2 + , V2 2 1, V2 2 3 + , V2 3 2 ] , testCase "radius 12, origin 0" - $ (sort . unique @[] @[_]) (circle @Int (0, 0) 12) - @?= [ (-12,-4),(-12,-3),(-12,-2),(-12,-1),(-12,0),(-12,1),(-12,2) - , (-12,3),(-12,4),(-11,-6),(-11,-5),(-11,5),(-11,6),(-10,-7),(-10,7) - , (-9,-9),(-9,-8),(-9,8),(-9,9),(-8,-9),(-8,9),(-7,-10),(-7,10) - , (-6,-11),(-6,11),(-5,-11),(-5 ,11),(-4,-12),(-4,12),(-3,-12),(-3,12) - , (-2,-12),(-2,12),(-1,-12),(-1,12),(0,-12),(0,12),(1,-12),(1,12) - , (2,-12),(2,12),(3,-12),(3,12),(4,-12),(4,12),(5,-11),(5 ,11),(6,-11) - , (6,11),(7,-10),(7,10),(8,-9),(8,9),(9,-9),(9,-8),(9,8),(9,9),(10,-7) - , (10,7),(11,-6),(11,-5),(11,5),(11,6),(12,-4),(12,-3),(12,-2),(12,-1) - , (12,0), (12,1),(12,2),(12,3),(12,4) + $ (sort . nub) (circle @Int 0 12) + @?= (sort . nub) + [ V2 (-12) (-4), V2 (-12) (-3), V2 (-12) (-2), V2 (-12) (-1) + , V2 (-12) 0, V2 (-12) 1, V2 (-12) 2, V2 (-12) 3, V2 (-12) 4 + , V2 (-11) (-6), V2 (-11) (-5), V2 (-11) 5, V2 (-11) 6, V2 (-10) (-7) + , V2 (-10) 7, V2 (-9) (-9), V2 (-9) (-8), V2 (-9) 8, V2 (-9) 9 + , V2 (-8) (-9), V2 (-8) 9, V2 (-7) (-10), V2 (-7) 10, V2 (-6) (-11) + , V2 (-6) 11, V2 (-5) (-11), V2 (-5) 11, V2 (-4) (-12), V2 (-4) 12 + , V2 (-3) (-12), V2 (-3) 12, V2 (-2) (-12), V2 (-2) 12, V2 (-1) (-12) + , V2 (-1) 12, V2 0 (-12), V2 0 12, V2 1 (-12), V2 1 12, V2 2 (-12) + , V2 2 12, V2 3 (-12), V2 3 12, V2 4 (-12), V2 4 12, V2 5 (-11) + , V2 5 11, V2 6 (-11), V2 6 11, V2 7 (-10), V2 7 10, V2 8 (-9), V2 8 9 + , V2 9 (-9), V2 9 (-8), V2 9 8, V2 9 9, V2 10 (-7), V2 10 7 + , V2 11 (-6), V2 11 (-5), V2 11 5, V2 11 6, V2 12 (-4), V2 12 (-3) + , V2 12 (-2), V2 12 (-1), V2 12 0, V2 12 1, V2 12 2, V2 12 3, V2 12 4 ] - ] , testGroup "filledCircle" [ testProperty "is a superset of circle" $ \center radius -> diff --git a/users/glittershark/xanthous/xanthous.cabal b/users/glittershark/xanthous/xanthous.cabal index 653389a4c5cb..3f093a37a15a 100644 --- a/users/glittershark/xanthous/xanthous.cabal +++ b/users/glittershark/xanthous/xanthous.cabal @@ -1,10 +1,10 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.33.1. -- -- see: https://github.com/sol/hpack -- --- hash: 5f419c8c149f045c818a2fb392b1233a0958e71e92d7a837deabc412e2b5adda +-- hash: bb0a26ab512a1b8d095f3fa71370dcc5221c3f20888042a0d5c41d054dc403cf name: xanthous version: 0.1.0.0 @@ -106,6 +106,7 @@ library , comonad-extras , constraints , containers + , criterion , data-default , deepseq , directory @@ -231,6 +232,7 @@ executable xanthous , comonad-extras , constraints , containers + , criterion , data-default , deepseq , directory @@ -323,6 +325,7 @@ test-suite test , comonad-extras , constraints , containers + , criterion , data-default , deepseq , directory |