module Math.Geometry.GridInternal where
import Prelude hiding (null)
import Data.Eq.Unicode ((≡))
import Data.Function (on)
import Data.List (groupBy, nub, nubBy, sortBy)
import Data.Ord (comparing)
class Grid g where
type Index g
type Direction g
indices ∷ g → [Index g]
distance ∷ g → Index g → Index g → Int
minDistance ∷ g → [Index g] → Index g → Int
minDistance = defaultMinDistance
neighbours ∷ g → Index g → [Index g]
neighbours = defaultNeighbours
neighbour ∷ Eq (Direction g) ⇒ g → Index g → Direction g → Index g
neighbour = defaultNeighbour
numNeighbours ∷ g → Index g → Int
numNeighbours g = length . neighbours g
contains ∷ Eq (Index g) ⇒ g → Index g → Bool
contains g a = a `elem` indices g
tileCount ∷ g → Int
tileCount = length . indices
null ∷ g → Bool
null g = tileCount g ≡ 0
nonNull ∷ g → Bool
nonNull = not . null
edges ∷ Eq (Index g) ⇒ g → [(Index g,Index g)]
edges = defaultEdges
viewpoint ∷ g → Index g → [(Index g, Int)]
viewpoint g p = map f (indices g)
where f a = (a, distance g p a)
isAdjacent ∷ g → Index g → Index g → Bool
isAdjacent = defaultIsAdjacent
adjacentTilesToward ∷ g → Index g → Index g → [Index g]
adjacentTilesToward = defaultAdjacentTilesToward
minimalPaths ∷ Eq (Index g) ⇒ g → Index g → Index g → [[Index g]]
minimalPaths = defaultMinimalPaths
directionTo ∷ g → Index g → Index g → [Direction g]
defaultMinDistance ∷ g → [Index g] → Index g → Int
defaultMinDistance g xs a = minimum . map (distance g a) $ xs
defaultNeighbours ∷ g → Index g → [Index g]
defaultNeighbours g a = filter (\b → distance g a b ≡ 1 ) $ indices g
defaultNeighbour ∷ Eq (Direction g)
⇒ g → Index g → Direction g → Index g
defaultNeighbour g a d =
head . filter (\b → [d] ≡ directionTo g a b) . neighbours g $ a
defaultTileCount ∷ g → Int
defaultTileCount = length . indices
defaultEdges ∷ Eq (Index g) ⇒ g → [(Index g,Index g)]
defaultEdges g = nubBy sameEdge $ concatMap (`adjacentEdges` g) $ indices g
defaultIsAdjacent ∷ g → Index g → Index g → Bool
defaultIsAdjacent g a b = distance g a b ≡ 1
defaultAdjacentTilesToward ∷ 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
sameEdge ∷ Eq t ⇒ (t, t) → (t, t) → Bool
sameEdge (a,b) (c,d) = (a,b) ≡ (c,d) || (a,b) ≡ (d,c)
adjacentEdges ∷ Grid 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..r1], c>0]
north = [(k,r1) | k ← [1,2..c1], r>0]
east = [(c1,k) | k ← [r2,r3..0], c>1]
south = [(k,0) | k ← [c2,c3..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 [m1,m] else [m]
where m = floor (k'/2.0)
k' = fromIntegral k ∷ Double
class Grid g ⇒ FiniteGrid g where
type Size s
size ∷ g → Size g
class Grid g ⇒ BoundedGrid g where
tileSideCount ∷ g → Int
boundary ∷ g → [Index g]
boundary g = map fst . filter f $ xds
where xds = map (\b → (b, numNeighbours g b)) $ indices g
f (_,n) = n < tileSideCount g
isBoundary ∷ Eq (Index g) ⇒ g → Index g → Bool
isBoundary g a = a `elem` boundary g
centre ∷ g → [Index g]
centre g = map fst . last . groupBy ((≡) `on` snd) .
sortBy (comparing snd) $ xds
where xds = map (\b → (b, minDistance g bs b)) $ indices g
bs = boundary g
isCentre ∷ Eq (Index g) ⇒ g → Index g → Bool
isCentre g a = a `elem` centre g
class (Grid g) ⇒ WrappedGrid g where
normalise ∷ g → Index g → Index g
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 → Index g
neighbourWrappedBasedOn u g a d =
if g `contains` a
then normalise g . neighbour u a $ d
else undefined
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