grid-5.1: src/Math/Geometry/GridInternal.hs

------------------------------------------------------------------------
-- |
-- Module      :  Math.Geometry.GridInternal
-- Copyright   :  (c) Amy de Buitléir 2012
-- 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 UnicodeSyntax, TypeFamilies, FlexibleContexts #-}

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)

-- | 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 ∷ g → Index g → [Index g]
  neighbours = defaultNeighbours

  -- | @'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 (Direction g) ⇒ g → Index g → Direction g → 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 ∷ 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 ∷ 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

  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

--
-- 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 ⇒ 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 = floor (k'/2.0)
        k' = fromIntegral k ∷ Double


-- | A regular arrangement of tiles where the number of tiles is finite.
--   Minimal complete definition: @size@.
class Grid g ⇒ FiniteGrid g where
  type Size s
  -- | 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


-- | 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 ∷ 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' 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 g a = a `elem` boundary g

  -- | 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 ∷ 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' 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 g a = a `elem` centre g

-- | A regular arrangement of tiles where the boundaries are joined.
--   Minimal complete definition: @normalise@.
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 → 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