module Math.Geometry.GridInternal
(
Grid(..),
FiniteGrid(..),
BoundedGrid(..),
WrappedGrid(..),
UnboundedTriGrid,
TriTriGrid,
triTriGrid,
ParaTriGrid,
paraTriGrid,
RectTriGrid,
rectTriGrid,
TorTriGrid,
torTriGrid,
UnboundedSquareGrid,
RectSquareGrid,
rectSquareGrid,
TorSquareGrid,
torSquareGrid,
UnboundedHexGrid,
HexHexGrid,
hexHexGrid,
ParaHexGrid,
paraHexGrid,
UnboundedOctGrid,
RectOctGrid,
rectOctGrid,
TorOctGrid,
torOctGrid,
) where
import Prelude hiding (null)
import Data.Eq.Unicode ((≡), (≠))
import Data.Function (on)
import Data.List (groupBy, nub, nubBy, sortBy)
import Data.Ord (comparing)
import Data.Ord.Unicode ((≤), (≥))
class Grid g where
type Index g
indices ∷ g → [Index g]
distance ∷ g → Index g → Index g → Int
minDistance ∷ g → [Index g] → Index g → Int
minDistance g xs x = minimum . map (distance g x) $ xs
neighbours ∷ g → Index g → [Index g]
neighbours g x = filter (\a → distance g x a ≡ 1 ) $ indices g
numNeighbours ∷ g → Index g → Int
numNeighbours g = length . neighbours g
contains ∷ Eq (Index g) ⇒ g → Index g → Bool
contains g x = x `elem` indices g
viewpoint ∷ g → Index g → [(Index g, Int)]
viewpoint g p = map f (indices g)
where f x = (x, distance g p x)
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 g = nubBy sameEdge $ concatMap (`adjacentEdges` g) $ indices g
isAdjacent ∷ Eq (Index g) ⇒ g → Index g → Index g → Bool
isAdjacent g a b = a `elem` (neighbours g b)
adjacentTilesToward ∷ g → Index g → Index g → [Index g]
adjacentTilesToward g a b = filter f $ neighbours g a
where f x = distance g x b ≡ distance g a b 1
minimalPaths ∷ Eq (Index g) ⇒ g → Index g → Index g → [[Index g]]
minimalPaths g a b | a ≡ b = [[a]]
| distance g a b ≡ 1 = [[a,b]]
| otherwise = map (a:) xs
where xs = concatMap (\x → minimalPaths g x 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
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 (\y → (y, numNeighbours g y)) $ indices g
f (_,n) = n < tileSideCount g
isBoundary ∷ Eq (Index g) ⇒ g → Index g → Bool
isBoundary g x = x `elem` boundary g
centre ∷ g → [Index g]
centre g = map fst . head . reverse . groupBy ((≡) `on` snd) .
sortBy (comparing snd) $ xds
where xds = map (\y → (y, minDistance g bs y)) $ indices g
bs = boundary g
isCentre ∷ Eq (Index g) ⇒ g → Index g → Bool
isCentre g x = x `elem` centre g
class (Grid g) ⇒ WrappedGrid g where
normalise ∷ g → Index g → Index g
neighboursBasedOn
∷ (Eq (Index g), Grid u, Grid g, Index u ~ Index g) ⇒
g → u → Index g → [Index g]
neighboursBasedOn u g = filter (g `contains`) . neighbours u
distanceBasedOn
∷ (Eq (Index g), Grid u, Grid g, Index u ~ Index g) ⇒
g → u → Index g → Index g → Int
distanceBasedOn u g a b =
if g `contains` a && g `contains` b
then distance u a b
else undefined
data UnboundedTriGrid = UnboundedTriGrid deriving Show
instance Grid UnboundedTriGrid where
type Index UnboundedTriGrid = (Int, Int)
indices _ = undefined
neighbours _ (x,y) = if even y
then [(x1,y+1), (x+1,y+1), (x+1,y1)]
else [(x1,y1), (x1,y+1), (x+1,y1)]
distance _ (x1, y1) (x2, y2) =
maximum [abs (x2x1), abs (y2y1), abs(z2z1)]
where z1 = triZ x1 y1
z2 = triZ x2 y2
contains _ _ = True
triZ ∷ Int → Int → Int
triZ x y = if even y then x y else x y + 1
data TriTriGrid = TriTriGrid Int [(Int, Int)] deriving Eq
instance Show TriTriGrid where
show (TriTriGrid s _) = "triTriGrid " ++ show s
instance Grid TriTriGrid where
type Index TriTriGrid = (Int, Int)
indices (TriTriGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedTriGrid
distance = distanceBasedOn UnboundedTriGrid
contains (TriTriGrid s _) (x, y) = inTriTriGrid (x,y) s
inTriTriGrid ∷ (Int, Int) → Int → Bool
inTriTriGrid (x, y) s = x ≥ 0 && y ≥ 0 && even (x+y) && abs z ≤ 2*s2
where z = triZ x y
instance FiniteGrid TriTriGrid where
type Size TriTriGrid = Int
size (TriTriGrid s _) = s
instance BoundedGrid TriTriGrid where
tileSideCount _ = 3
boundary g = west ++ east ++ south
where s = size g
west = [(0,k) | k ← [0,2..2*s2]]
east = [(k,2*s2k) | k ← [2,4..2*s2]]
south = [(k,0) | k ← [2*s4,2*s6..2]]
centre g = case s `mod` 3 of
0 → trefoilWithTop (k1,k+1) where k = (2*s) `div` 3
1 → [(k,k)] where k = (2*(s1)) `div` 3
2 → [(k+1,k+1)] where k = (2*(s2)) `div` 3
_ → error "This will never happen."
where s = size g
trefoilWithTop (i,j) = [(i,j), (i+2, j2), (i,j2)]
triTriGrid ∷ Int → TriTriGrid
triTriGrid s =
TriTriGrid s [(xx,yy) | xx ← [0..2*(s1)],
yy ← [0..2*(s1)],
(xx,yy) `inTriTriGrid` s]
data ParaTriGrid = ParaTriGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show ParaTriGrid where
show (ParaTriGrid (r,c) _) = "paraTriGrid " ++ show r ++ " " ++ show c
instance Grid ParaTriGrid where
type Index ParaTriGrid = (Int, Int)
indices (ParaTriGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedTriGrid
distance = distanceBasedOn UnboundedTriGrid
instance FiniteGrid ParaTriGrid where
type Size ParaTriGrid = (Int, Int)
size (ParaTriGrid s _) = s
instance BoundedGrid ParaTriGrid where
tileSideCount _ = 3
boundary g = west ++ north ++ east ++ south
where (r,c) = size g
west = [(0,k) | k ← [0,2..2*r2], c>0]
north = [(k,2*r1) | k ← [1,3..2*c1], r>0]
east = [(2*c1,k) | k ← [2*r3,2*r5..1], c>0]
south = [(k,0) | k ← [2*c2,2*c4..2], r>0]
centre g = f . size $ g
where f (r,c)
| odd r && odd c
= [(c1,r1), (c,r)]
| even r && even c && r ≡ c
= bowtie (c1,r1)
| even r && even c && r > c
= bowtie (c1,r3) ++ bowtie (c1,r1) ++ bowtie (c1,r+1)
| even r && even c && r < c
= bowtie (c3,r1) ++ bowtie (c1,r1) ++ bowtie (c+1,r1)
| otherwise
= [(c1,r), (c,r1)]
bowtie (i,j) = [(i,j), (i+1,j+1)]
paraTriGrid ∷ Int → Int → ParaTriGrid
paraTriGrid r c =
ParaTriGrid (r,c) [(x,y) | x ← [0..2*c1], y ← [0..2*r1], even (x+y)]
data RectTriGrid = RectTriGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show RectTriGrid where
show (RectTriGrid (r,c) _) = "rectTriGrid " ++ show r ++ " " ++ show c
instance Grid RectTriGrid where
type Index RectTriGrid = (Int, Int)
indices (RectTriGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedTriGrid
distance = distanceBasedOn UnboundedTriGrid
instance FiniteGrid RectTriGrid where
type Size RectTriGrid = (Int, Int)
size (RectTriGrid s _) = s
instance BoundedGrid RectTriGrid where
tileSideCount _ = 3
rectTriGrid ∷ Int → Int → RectTriGrid
rectTriGrid r c = RectTriGrid (r,c) [(x,y) | y ← [0..2*r1], x ← [xMin y .. xMax c y], even (x+y)]
where xMin y = if even y then w else w+1
where w = 2*((y+1) `div` 4)
xMax c2 y = xMin y + 2*(c21)
data TorTriGrid = TorTriGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show TorTriGrid where
show (TorTriGrid (r,c) _) = "torTriGrid " ++ show r ++ " " ++ show c
instance Grid TorTriGrid where
type Index TorTriGrid = (Int, Int)
indices (TorTriGrid _ xs) = xs
neighbours g = nub . map (normalise g) . neighbours UnboundedTriGrid
distance g (xa, ya) (xb, yb) =
if g `contains` (xa, ya) && g `contains` (xb, yb)
then minimum [distance UnboundedTriGrid (xa, ya) (xb, yb),
distance UnboundedTriGrid (xa, ya) (xb + 2*c, yb),
distance UnboundedTriGrid (xa, ya) (xb r, yb + 2*r),
distance UnboundedTriGrid (xa, ya) (xb, yb),
distance UnboundedTriGrid (xa + 2*c, ya) (xb, yb),
distance UnboundedTriGrid (xa r, ya + 2*r) (xb, yb)]
else undefined
where (r,c) = size g
xMinTorTri ∷ Int → Int
xMinTorTri y = if even y then w else w+1
where w = 2*((y+1) `div` 4)
instance FiniteGrid TorTriGrid where
type Size TorTriGrid = (Int, Int)
size (TorTriGrid s _) = s
instance WrappedGrid TorTriGrid where
normalise g (x,y)
| y < 0 = normalise g (xr,y+2*r)
| y > 2*r1 = normalise g (x+r,y2*r)
| x < xMin = normalise g (x+2*c,y)
| x > xMin + 2*c1 = normalise g (x2*c,y)
| otherwise = (x,y)
where xMin = xMinTorTri y
(r, c) = size g
torTriGrid ∷ Int → Int → TorTriGrid
torTriGrid r c =
if even r
then TorTriGrid (r,c) [(x,y) | y ← [0..2*r1],
x ← [xMinTorTri y .. xMax c y],
even (x+y)]
else undefined
where xMax c2 y = xMinTorTri y + 2*(c21)
data UnboundedSquareGrid = UnboundedSquareGrid deriving Show
instance Grid UnboundedSquareGrid where
type Index UnboundedSquareGrid = (Int, Int)
indices _ = undefined
neighbours _ (x,y) = [(x,y+1), (x,y1), (x+1,y), (x1,y)]
distance _ (x1, y1) (x2, y2) = abs (x2x1) + abs (y2y1)
contains _ _ = True
data RectSquareGrid = RectSquareGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show RectSquareGrid where
show (RectSquareGrid (r,c) _) =
"rectSquareGrid " ++ show r ++ " " ++ show c
instance Grid RectSquareGrid where
type Index RectSquareGrid = (Int, Int)
indices (RectSquareGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedSquareGrid
distance = distanceBasedOn UnboundedSquareGrid
adjacentTilesToward g a@(x1, y1) (x2, y2) =
filter (\i → g `contains` i && i ≠ a) $ nub [(x1,y1+dy),(x1+dx,y1)]
where dx = signum (x2x1)
dy = signum (y2y1)
instance FiniteGrid RectSquareGrid where
type Size RectSquareGrid = (Int, Int)
size (RectSquareGrid s _) = s
instance BoundedGrid RectSquareGrid where
tileSideCount _ = 4
boundary g = cartesianIndices . size $ g
centre g = cartesianCentre . size $ g
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 ← midpoints c, j ← midpoints r]
midpoints ∷ Int → [Int]
midpoints k = if even k then [m1,m] else [m]
where m = floor (k'/2.0)
k' = fromIntegral k ∷ Double
rectSquareGrid ∷ Int → Int → RectSquareGrid
rectSquareGrid r c =
RectSquareGrid (r,c) [(x,y) | x ← [0..c1], y ← [0..r1]]
data TorSquareGrid = TorSquareGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show TorSquareGrid where
show (TorSquareGrid (r,c) _) = "torSquareGrid " ++ show r ++ " " ++ show c
instance Grid TorSquareGrid where
type Index TorSquareGrid = (Int, Int)
indices (TorSquareGrid _ xs) = xs
neighbours g = nub . map (normalise g) . neighbours UnboundedSquareGrid
distance g@(TorSquareGrid (r,c) _) (x1, y1) (x2, y2) =
if g `contains` (x1, y1) && g `contains` (x2, y2)
then min adx (abs (cadx)) + min ady (abs (rady))
else undefined
where adx = abs (x2 x1)
ady = abs (y2 y1)
instance FiniteGrid TorSquareGrid where
type Size TorSquareGrid = (Int, Int)
size (TorSquareGrid s _) = s
instance WrappedGrid TorSquareGrid where
normalise g (x,y) = (x `mod` c, y `mod` r)
where (r, c) = size g
denormaliseTor
:: (FiniteGrid g, Index g ~ (Int, Int), (Int, Int) ~ Size g) =>
g -> Index g -> [Index g]
denormaliseTor g (x,y) = nub [(x2,y1), (x,y1), (x1,y1),
(x2,y), (x,y), (x1,y),
(x2,y2), (x,y2), (x1,y2)]
where (r, c) = size g
x1 = x + c
y1 = y + r
x2 = x c
y2 = y r
torSquareGrid ∷ Int → Int → TorSquareGrid
torSquareGrid r c = TorSquareGrid (r,c) [(x, y) | x ← [0..c1], y ← [0..r1]]
data UnboundedHexGrid = UnboundedHexGrid deriving Show
instance Grid UnboundedHexGrid where
type Index UnboundedHexGrid = (Int, Int)
indices _ = undefined
neighbours _ (x,y) =
[(x1,y), (x1,y+1), (x,y+1), (x+1,y), (x+1,y1), (x,y1)]
distance _ (x1, y1) (x2, y2) =
maximum [abs (x2x1), abs (y2y1), abs(z2z1)]
where z1 = x1 y1
z2 = x2 y2
contains _ _ = True
data HexHexGrid = HexHexGrid Int [(Int, Int)] deriving Eq
instance Show HexHexGrid where show (HexHexGrid s _) = "hexHexGrid " ++ show s
instance Grid HexHexGrid where
type Index HexHexGrid = (Int, Int)
indices (HexHexGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedHexGrid
distance = distanceBasedOn UnboundedHexGrid
instance FiniteGrid HexHexGrid where
type Size HexHexGrid = Int
size (HexHexGrid s _) = s
instance BoundedGrid HexHexGrid where
tileSideCount _ = 6
boundary g =
north ++ northeast ++ southeast ++ south ++ southwest ++ northwest
where s = size g
north = [(k,s1) | k ← [s+1,s+2..0]]
northeast = [(k,s1k) | k ← [1,2..s1]]
southeast = [(s1,k) | k ← [1,2..(s)+1]]
south = [(k,(s)+1) | k ← [s2,s3..0]]
southwest = [(k,(s)+1k) | k ← [1,2..(s)+1]]
northwest = [(s+1,k) | k ← [1,2..s2]]
centre _ = [(0,0)]
hexHexGrid ∷ Int → HexHexGrid
hexHexGrid r = HexHexGrid r [(x, y) | x ← [r+1..r1], y ← f x]
where f x = if x < 0 then [1rx .. r1] else [1r .. r1x]
data ParaHexGrid = ParaHexGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show ParaHexGrid where
show (ParaHexGrid (r,c) _) = "paraHexGrid " ++ show r ++ " " ++ show c
instance Grid ParaHexGrid where
type Index ParaHexGrid = (Int, Int)
indices (ParaHexGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedHexGrid
distance = distanceBasedOn UnboundedHexGrid
instance FiniteGrid ParaHexGrid where
type Size ParaHexGrid = (Int, Int)
size (ParaHexGrid s _) = s
instance BoundedGrid ParaHexGrid where
tileSideCount _ = 6
boundary g = cartesianIndices . size $ g
centre g = cartesianCentre . size $ g
paraHexGrid ∷ Int → Int → ParaHexGrid
paraHexGrid r c =
ParaHexGrid (r,c) [(x, y) | x ← [0..c1], y ← [0..r1]]
data UnboundedOctGrid = UnboundedOctGrid deriving Show
instance Grid UnboundedOctGrid where
type Index UnboundedOctGrid = (Int, Int)
indices _ = undefined
neighbours _ (x,y) = [(x1,y+1), (x,y+1), (x+1,y+1), (x+1,y),
(x+1,y1), (x,y1), (x1,y1), (x1,y)]
distance _ (x1, y1) (x2, y2) = max (abs (x2x1)) (abs (y2y1))
contains _ _ = True
data RectOctGrid = RectOctGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show RectOctGrid where
show (RectOctGrid (r,c) _) =
"rectOctGrid " ++ show r ++ " " ++ show c
instance Grid RectOctGrid where
type Index RectOctGrid = (Int, Int)
indices (RectOctGrid _ xs) = xs
neighbours = neighboursBasedOn UnboundedOctGrid
distance = distanceBasedOn UnboundedOctGrid
instance FiniteGrid RectOctGrid where
type Size RectOctGrid = (Int, Int)
size (RectOctGrid s _) = s
instance BoundedGrid RectOctGrid where
tileSideCount _ = 4
boundary g = cartesianIndices . size $ g
centre g = cartesianCentre . size $ g
rectOctGrid ∷ Int → Int → RectOctGrid
rectOctGrid r c =
RectOctGrid (r,c) [(x,y) | x ← [0..c1], y ← [0..r1]]
data TorOctGrid = TorOctGrid (Int, Int) [(Int, Int)] deriving Eq
instance Show TorOctGrid where
show (TorOctGrid (r,c) _) = "torOctGrid " ++ show r ++ " " ++ show c
instance Grid TorOctGrid where
type Index TorOctGrid = (Int, Int)
indices (TorOctGrid _ xs) = xs
neighbours g = nub . map (normalise g) . neighbours UnboundedOctGrid
distance g a b = minimum . map (distance UnboundedOctGrid a) $ bs
where bs = denormaliseTor g b
instance FiniteGrid TorOctGrid where
type Size TorOctGrid = (Int, Int)
size (TorOctGrid s _) = s
instance WrappedGrid TorOctGrid where
normalise g (x,y) = (x `mod` c, y `mod` r)
where (r, c) = size g
torOctGrid ∷ Int → Int → TorOctGrid
torOctGrid r c = TorOctGrid (r,c) [(x, y) | x ← [0..c1], y ← [0..r1]]