------------------------------------------------------------------------
-- |
-- Module : Math.Geometry.GridInternal
-- Copyright : (c) Amy de BuitlĂ©ir 2012-2017
-- License : BSD-style
-- Maintainer : amy@nualeargais.ie
-- Stability : experimental
-- Portability : portable
--
-- A module containing private @Grid@ internals. Most developers should
-- use @Grid@ instead. This module is subject to change without notice.
--
------------------------------------------------------------------------
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstrainedClassMethods #-}
module Math.Geometry.GridInternal where
import Prelude hiding (null)
import Data.Function (on)
import Data.List ((\\), groupBy, nub, nubBy, sortBy)
import Data.Ord (comparing)
-- | A regular arrangement of tiles.
-- Minimal complete definition: @'Index'@, @'Direction'@, @'indices'@,
-- @'distance'@, @'directionTo'@.
class Grid g where
type Index g
type Direction g
-- | Returns the indices of all tiles in a grid.
indices :: g -> [Index g]
-- | @'distance' g a b@ returns the minimum number of moves required
-- to get from the tile at index @a@ to the tile at index @b@ in
-- grid @g@, moving between adjacent tiles at each step. (Two tiles
-- are adjacent if they share an edge.) If @a@ or @b@ are not
-- contained within @g@, the result is undefined.
distance :: g -> Index g -> Index g -> Int
-- | @'minDistance' g bs a@ returns the minimum number of moves
-- required to get from any of the tiles at indices @bs@ to the tile
-- at index @a@ in grid @g@, moving between adjacent tiles at each
-- step. (Two tiles are adjacent if they share an edge.) If @a@ or
-- any of @bs@ are not contained within @g@, the result is
-- undefined.
minDistance :: g -> [Index g] -> Index g -> Int
minDistance = defaultMinDistance
-- | @'neighbours' g a@ returns the indices of the tiles in the grid
-- @g@ which are adjacent to the tile with index @a@.
neighbours :: Eq (Index g) => g -> Index g -> [Index g]
neighbours = defaultNeighbours
-- | @'neighboursOfSet' g as@ returns the indices of the tiles in the
-- grid @g@ which are adjacent to any of the tiles with index in
-- @as@.
neighboursOfSet :: Eq (Index g) => g -> [Index g] -> [Index g]
neighboursOfSet = defaultNeighboursOfSet
-- | @'neighbour' g d a@ returns the indices of the tile in the grid
-- @g@ which is adjacent to the tile with index @a@, in the
-- direction @d@.
neighbour
:: (Eq (Index g), Eq (Direction g))
=> g -> Index g -> Direction g -> Maybe (Index g)
neighbour = defaultNeighbour
-- | @'numNeighbours' g a@ returns the number of tiles in the grid
-- @g@ which are adjacent to the tile with index @a@.
numNeighbours :: Eq (Index g) => g -> Index g -> Int
numNeighbours g = length . neighbours g
-- | @g `'contains'` a@ returns @True@ if the index @a@ is contained
-- within the grid @g@, otherwise it returns false.
contains :: Eq (Index g) => g -> Index g -> Bool
contains g a = a `elem` indices g
-- | Returns the number of tiles in a grid. Compare with @'size'@.
tileCount :: g -> Int
tileCount = length . indices
-- | Returns @True@ if the number of tiles in a grid is zero, @False@
-- otherwise.
null :: g -> Bool
null g = tileCount g == 0
-- | Returns @False@ if the number of tiles in a grid is zero, @True@
-- otherwise.
nonNull :: g -> Bool
nonNull = not . null
-- | A list of all edges in a grid, where the edges are represented by
-- a pair of indices of adjacent tiles.
edges :: Eq (Index g) => g -> [(Index g,Index g)]
edges = defaultEdges
-- | @'viewpoint' g a@ returns a list of pairs associating the index
-- of each tile in @g@ with its distance to the tile with index @a@.
-- If @a@ is not contained within @g@, the result is undefined.
viewpoint :: g -> Index g -> [(Index g, Int)]
viewpoint g p = map f (indices g)
where f a = (a, distance g p a)
-- | @'isAdjacent' g a b@ returns @True@ if the tile at index @a@ is
-- adjacent to the tile at index @b@ in @g@. (Two tiles are adjacent
-- if they share an edge.) If @a@ or @b@ are not contained within
-- @g@, the result is undefined.
isAdjacent :: g -> Index g -> Index g -> Bool
isAdjacent = defaultIsAdjacent
-- | @'adjacentTilesToward' g a b@ returns the indices of all tiles
-- which are neighbours of the tile at index @a@, and which are
-- closer to the tile at @b@ than @a@ is. In other words, it returns
-- the possible next steps on a minimal path from @a@ to @b@. If @a@
-- or @b@ are not contained within @g@, or if there is no path from
-- @a@ to @b@ (e.g., a disconnected grid), the result is undefined.
adjacentTilesToward :: Eq (Index g) => g -> Index g -> Index g -> [Index g]
adjacentTilesToward = defaultAdjacentTilesToward
-- | @'minimalPaths' g a b@ returns a list of all minimal paths from
-- the tile at index @a@ to the tile at index @b@ in grid @g@. A
-- path is a sequence of tiles where each tile in the sequence is
-- adjacent to the previous one. (Two tiles are adjacent if they
-- share an edge.) If @a@ or @b@ are not contained within @g@, the
-- result is undefined.
--
-- Tip: The default implementation of this function calls
-- @'adjacentTilesToward'@. If you want to use a custom algorithm,
-- consider modifying @'adjacentTilesToward'@ instead of
-- @'minimalPaths'@.
minimalPaths :: Eq (Index g) => g -> Index g -> Index g -> [[Index g]]
minimalPaths = defaultMinimalPaths
-- | @'directionTo' g a b@ returns the direction(s) of the next
-- tile(s) in a /minimal/ path from the tile at index @a@ to the
-- tile at index @b@ in grid @g@.
directionTo :: g -> Index g -> Index g -> [Direction g]
--
-- These default implementations are broken out to make it easier to
-- compare the results with custom implementations (for testing).
--
defaultMinDistance :: g -> [Index g] -> Index g -> Int
defaultMinDistance g xs a = minimum . map (distance g a) $ xs
-- WARNING: this implementation won't work for wrapped grids
defaultNeighbours :: g -> Index g -> [Index g]
defaultNeighbours g a = filter (\b -> distance g a b == 1 ) $ indices g
-- This should work for wrapped grids, though.
defaultNeighboursOfSet :: Eq (Index g) => g -> [Index g] -> [Index g]
defaultNeighboursOfSet g as = ns \\ as
where ns = nub . concatMap (neighbours g) $ as
-- WARNING: this implementation won't work for wrapped grids
defaultNeighbour :: (Eq (Index g), Eq (Direction g))
=> g -> Index g -> Direction g -> Maybe (Index g)
defaultNeighbour g a d =
maybeHead . filter (\b -> [d] == directionTo g a b) . neighbours g $ a
where maybeHead (x:_) = Just x
maybeHead _ = Nothing
defaultTileCount :: g -> Int
defaultTileCount = length . indices
-- WARNING: this implementation won't work for wrapped grids
defaultEdges :: Eq (Index g) => g -> [(Index g,Index g)]
defaultEdges g = nubBy sameEdge $ concatMap (`adjacentEdges` g) $ indices g
-- WARNING: this implementation won't work for wrapped grids
defaultIsAdjacent :: g -> Index g -> Index g -> Bool
defaultIsAdjacent g a b = distance g a b == 1
defaultAdjacentTilesToward
:: Eq (Index g) => g -> Index g -> Index g -> [Index g]
defaultAdjacentTilesToward g a b = filter f $ neighbours g a
where f c = distance g c b == distance g a b - 1
defaultMinimalPaths :: Eq (Index g)
=> g -> Index g -> Index g -> [[Index g]]
defaultMinimalPaths g a b
| a == b = [[a]]
| distance g a b == 1 = [[a,b]]
| otherwise = map (a:) xs
where xs = concatMap (\c -> minimalPaths g c b) ys
ys = adjacentTilesToward g a b
-- | A regular arrangement of tiles where the number of tiles is finite.
-- Minimal complete definition: @'size'@, @'maxPossibleDistance'@.
class Grid g => FiniteGrid g where
type Size g
-- | Returns the dimensions of the grid.
-- For example, if @g@ is a 4x3 rectangular grid, @'size' g@ would
-- return @(4, 3)@, while @'tileCount' g@ would return @12@.
size :: g -> Size g
-- | Returns the largest possible distance between two tiles in the
-- grid.
maxPossibleDistance :: g -> Int
-- | A regular arrangement of tiles with an edge.
-- Minimal complete definition: @'tileSideCount'@.
class Grid g => BoundedGrid g where
-- | Returns the number of sides a tile has
tileSideCount :: g -> Int
-- | Returns a the indices of all the tiles at the boundary of a grid.
boundary :: Eq (Index g) => g -> [Index g]
boundary = defaultBoundary
-- | @'isBoundary' g a@' returns @True@ if the tile with index @a@ is
-- on a boundary of @g@, @False@ otherwise. (Corner tiles are also
-- boundary tiles.)
isBoundary :: Eq (Index g) => g -> Index g -> Bool
isBoundary = defaultIsBoundary
-- | Returns the index of the tile(s) that require the maximum number
-- of moves to reach the nearest boundary tile. A grid may have more
-- than one central tile (e.g., a rectangular grid with an even
-- number of rows and columns will have four central tiles).
centre :: Eq (Index g) => g -> [Index g]
centre = defaultCentre
-- | @'isCentre' g a@' returns @True@ if the tile with index @a@ is
-- a centre tile of @g@, @False@ otherwise.
isCentre :: Eq (Index g) => g -> Index g -> Bool
isCentre = defaultIsCentre
--
-- These default implementations are broken out to make it easier to
-- compare the results with custom implementations (for testing).
--
defaultBoundary :: Eq (Index g) => g -> [Index g]
defaultBoundary g = map fst . filter f $ xds
where xds = map (\b -> (b, numNeighbours g b)) $ indices g
f (_,n) = n < tileSideCount g
defaultIsBoundary :: Eq (Index g) => g -> Index g -> Bool
defaultIsBoundary g a = a `elem` boundary g
-- WARNING: this implementation won't work for triangular grids.
-- It probably only works on grids where all the tiles have the same
-- shape/orientation.
defaultCentre :: Eq (Index g) => g -> [Index g]
defaultCentre g = map fst . head . groupBy ((==) `on` snd) .
sortBy (comparing snd) $ xds
where xds = map (\b -> (b, f b)) $ indices g
bs = boundary g
f x = sum . map (distance g x) $ bs
defaultIsCentre :: Eq (Index g) => g -> Index g -> Bool
defaultIsCentre g a = a `elem` centre g
-- | A regular arrangement of tiles where the boundaries are joined.
-- Minimal complete definition: @'normalise'@ and @'denormalise'@.
class (Grid g) => WrappedGrid g where
-- | @'normalise' g a@ returns the "normal" indices for @a@.
-- TODO: need a clearer description and an illustration.
normalise :: g -> Index g -> Index g
-- | @'denormalise' g a@ returns all of the indices in @a@'s
-- translation group. In other words, it returns @a@ plus the
-- indices obtained by translating @a@ in each direction by the
-- extent of the grid along that direction.
-- TODO: need a clearer description and an illustration.
denormalise :: g -> Index g -> [Index g]
neighboursBasedOn
:: (Eq (Index u), Grid g, Grid u, Index g ~ Index u) =>
u -> g -> Index g -> [Index g]
neighboursBasedOn u g = filter (g `contains`) . neighbours u
distanceBasedOn
:: (Eq (Index g), Grid g, Grid u, Index g ~ Index u) =>
u -> g -> Index g -> Index g -> Int
distanceBasedOn u g a b =
if g `contains` a && g `contains` b
then distance u a b
else undefined
directionToBasedOn
:: (Eq (Index g), Eq (Direction g), Grid g, Grid u, Index g ~ Index u,
Direction g ~ Direction u) =>
u -> g -> Index g -> Index g -> [Direction g]
directionToBasedOn u g a b =
if g `contains` a && g `contains` b
then nub . concatMap (directionTo u a) . adjacentTilesToward g a $ b
else undefined
neighboursWrappedBasedOn
:: (Eq (Index g), WrappedGrid g, Grid u, Index g ~ Index u) =>
u -> g -> Index g -> [Index g]
neighboursWrappedBasedOn u g =
filter (g `contains`) . nub . map (normalise g) . neighbours u
neighbourWrappedBasedOn
:: (Eq (Index g), Eq (Direction g), WrappedGrid g, Grid u,
Index g ~ Index u, Direction g ~ Direction u) =>
u -> g -> Index g -> Direction g -> Maybe (Index g)
neighbourWrappedBasedOn u g a d =
if g `contains` a
then neighbour u a d >>= return . normalise g
else Nothing
distanceWrappedBasedOn
:: (Eq (Index g), WrappedGrid g, Grid u, Index g ~ Index u) =>
u -> g -> Index g -> Index g -> Int
distanceWrappedBasedOn u g a b =
if g `contains` a && g `contains` b
then minimum . map (distance u a') $ bs
else undefined
where a' = normalise g a
bs = denormalise g b
directionToWrappedBasedOn
:: (Eq (Index g), Eq (Direction g), WrappedGrid g, Grid u,
Index g ~ Index u, Direction g ~ Direction u) =>
u -> g -> Index g -> Index g -> [Direction g]
directionToWrappedBasedOn u g a b =
if g `contains` a && g `contains` b
then nub . concatMap (directionTo u a') $ ys'
else undefined
where a' = normalise g a
ys = denormalise g b
minD = distance g a b
ys' = filter (\c -> distance u a' c == minD) ys
--
-- Helper functions
--
sameEdge :: Eq t => (t, t) -> (t, t) -> Bool
sameEdge (a,b) (c,d) = (a,b) == (c,d) || (a,b) == (d,c)
adjacentEdges :: (Grid g, Eq (Index g)) => Index g -> g -> [(Index g, Index g)]
adjacentEdges i g = map (\j -> (i,j)) $ neighbours g i
cartesianIndices
:: (Enum r, Enum c, Num r, Num c, Ord r, Ord c) =>
(r, c) -> [(c, r)]
cartesianIndices (r, c) = west ++ north ++ east ++ south
where west = [(0,k) | k <- [0,1..r-1], c>0]
north = [(k,r-1) | k <- [1,2..c-1], r>0]
east = [(c-1,k) | k <- [r-2,r-3..0], c>1]
south = [(k,0) | k <- [c-2,c-3..1], r>1]
cartesianCentre :: (Int, Int) -> [(Int, Int)]
cartesianCentre (r,c) = [(i,j) | i <- cartesianMidpoints c, j <- cartesianMidpoints r]
cartesianMidpoints :: Int -> [Int]
cartesianMidpoints k = if even k then [m-1,m] else [m]
where m = k `div` 2