mdebray/tvl-depot
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor(xan): Switch to V2 over tuples most places

Browse source 
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 2020-07-03 20:32:36 -04:00 committed by glittershark
parent 4455f28e42
commit 9b8d3185fe
12 changed files with 172 additions and 143 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
users/glittershark/xanthous/src/Xanthous/Data.hs
View file

@ -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

2
users/glittershark/xanthous/src/Xanthous/Data/EntityMap/Graphics.hs
View file

@ -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)

7
users/glittershark/xanthous/src/Xanthous/Generators.hs
View file

@ -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

3
users/glittershark/xanthous/src/Xanthous/Generators/CaveAutomata.hs
View file

@ -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

9
users/glittershark/xanthous/src/Xanthous/Generators/Dungeon.hs
View file

@ -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)

21
users/glittershark/xanthous/src/Xanthous/Generators/LevelContents.hs
View file

@ -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)

96
users/glittershark/xanthous/src/Xanthous/Generators/Util.hs
View file

@ -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

4
users/glittershark/xanthous/src/Xanthous/Generators/Village.hs
View file

@ -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

84
users/glittershark/xanthous/src/Xanthous/Util/Graphics.hs
View file

@ -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)
)

23
users/glittershark/xanthous/test/Xanthous/Generators/UtilSpec.hs
View file

@ -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

41
users/glittershark/xanthous/test/Xanthous/Util/GraphicsSpec.hs
View file

@ -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 ->

7
users/glittershark/xanthous/xanthous.cabal
View file

@ -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