diff --git a/grid.cabal b/grid.cabal --- a/grid.cabal +++ b/grid.cabal @@ -1,5 +1,5 @@ name: grid -version: 5.0 +version: 5.1 synopsis: Tools for working with regular grids (graphs, lattices). description: Provides tools for working with regular arrangements of tiles, such as might be used in a board game or some @@ -33,7 +33,15 @@ containers ==0.4.2.* || ==0.5.* ghc-options: -Wall exposed-modules: Math.Geometry.Grid, + Math.Geometry.Grid.Triangular, + Math.Geometry.Grid.Square, + Math.Geometry.Grid.Hexagonal, + Math.Geometry.Grid.Octagonal, Math.Geometry.GridInternal, + Math.Geometry.Grid.TriangularInternal, + Math.Geometry.Grid.SquareInternal, + Math.Geometry.Grid.HexagonalInternal, + Math.Geometry.Grid.OctagonalInternal, Math.Geometry.GridMap, Math.Geometry.GridMap.Lazy diff --git a/src/Math/Geometry/Grid.hs b/src/Math/Geometry/Grid.hs --- a/src/Math/Geometry/Grid.hs +++ b/src/Math/Geometry/Grid.hs @@ -37,6 +37,8 @@ -- You can still /display/ the tiles as squares, but for internal -- calculations they are octagons. -- +-- NOTE: Version 6.0 moved the various grid flavours to sub-modules. +-- -- NOTE: Version 4.0 uses associated (type) synonyms instead of -- multi-parameter type classes. -- @@ -52,61 +54,23 @@ ( -- * Example -- $Example - -- * The Grid class - Grid(..), + + -- * Grids + Grid(indices, distance, minDistance, neighbours, neighbour, + contains, tileCount, null, nonNull, edges, isAdjacent, + adjacentTilesToward, minimalPaths, directionTo), + Index, + Direction, + + -- * Finite grids FiniteGrid(..), - BoundedGrid(..), - -- * Grids with triangular tiles - -- ** Unbounded grid with triangular tiles - UnboundedTriGrid, - -- ** Triangular grid with triangular tiles - TriTriGrid, - triTriGrid, - -- ** Parallelogram-shaped grid with triangular tiles - ParaTriGrid, - paraTriGrid, - -- ** Rectangular grid with triangular tiles - RectTriGrid, - rectTriGrid, - -- ** Toroidal grid with triangular tiles - TorTriGrid, - torTriGrid, - -- * Grids with square tiles - -- ** Unbounded grid with square tiles - UnboundedSquareGrid, - -- ** Rectangular grid with square tiles - RectSquareGrid, - rectSquareGrid, - -- ** Toroidal grid with square tiles - TorSquareGrid, - torSquareGrid, - -- * Grids with hexagonal tiles - -- ** Unbounded grid with hexagonal tiles - UnboundedHexGrid, - -- ** Hexagonal grid with hexagonal tiles - HexHexGrid, - hexHexGrid, - -- ** Parallelogram-shaped grid with hexagonal tiles - ParaHexGrid, - paraHexGrid, - -- * Grids with octagonal tiles - -- ** Unbounded grid with octagonal tiles - UnboundedOctGrid, - -- ** Rectangular grid with octagonal tiles - RectOctGrid, - rectOctGrid, - -- ** Toroidal grid with octagonal tiles - TorOctGrid, - torOctGrid + + -- * Bounded grids + BoundedGrid(..) ) where import Math.Geometry.GridInternal (Grid(..), FiniteGrid(..), - BoundedGrid(..), UnboundedTriGrid, TriTriGrid, triTriGrid, - ParaTriGrid, paraTriGrid, RectTriGrid, rectTriGrid, - TorTriGrid, torTriGrid, UnboundedSquareGrid, - RectSquareGrid, rectSquareGrid, TorSquareGrid, torSquareGrid, - UnboundedHexGrid, HexHexGrid, hexHexGrid, ParaHexGrid, paraHexGrid, - UnboundedOctGrid, RectOctGrid, rectOctGrid, TorOctGrid, torOctGrid) + BoundedGrid(..)) {- $Example diff --git a/src/Math/Geometry/Grid/Hexagonal.hs b/src/Math/Geometry/Grid/Hexagonal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/Hexagonal.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Geometry.HexGrid +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A regular arrangement of hexagonal tiles. +-- The userguide, with illustrations, is available at +-- . +-- Also see @Math.Geometry.Grid@ for examples of how to use this class. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances #-} + +module Math.Geometry.Grid.Hexagonal + ( + -- * Unbounded grid with hexagonal tiles + UnboundedHexGrid, + -- * Hexagonal grid with hexagonal tiles + HexHexGrid, + hexHexGrid, + -- * Parallelogram-shaped grid with hexagonal tiles + ParaHexGrid, + paraHexGrid + ) where + +import Math.Geometry.Grid.HexagonalInternal (UnboundedHexGrid, HexHexGrid, + hexHexGrid, ParaHexGrid, paraHexGrid) + diff --git a/src/Math/Geometry/Grid/HexagonalInternal.hs b/src/Math/Geometry/Grid/HexagonalInternal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/HexagonalInternal.hs @@ -0,0 +1,145 @@ +------------------------------------------------------------------------ +-- | +-- Module : Math.Geometry.HexGridInternal +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A module containing private @HexGrid@ internals. Most developers +-- should use @HexGrid@ instead. This module is subject to change +-- without notice. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} + +module Math.Geometry.Grid.HexagonalInternal where + +import Prelude hiding (null) +import Data.Ord.Unicode ((≤)) +import Math.Geometry.GridInternal + +data HexDirection = West | Northwest | Northeast | East | Southeast | + Southwest deriving (Show, Eq) + +-- | An unbounded grid with hexagonal tiles +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +data UnboundedHexGrid = UnboundedHexGrid deriving Show + +instance Grid UnboundedHexGrid where + type Index UnboundedHexGrid = (Int, Int) + type Direction UnboundedHexGrid = HexDirection + indices _ = undefined + neighbours _ (x,y) = + [(x-1,y), (x-1,y+1), (x,y+1), (x+1,y), (x+1,y-1), (x,y-1)] + distance _ (x1, y1) (x2, y2) = + maximum [abs (x2-x1), abs (y2-y1), abs(z2-z1)] + where z1 = -x1 - y1 + z2 = -x2 - y2 + directionTo _ (x1, y1) (x2, y2) = f1 . f2 . f3 . f4 . f5 . f6 $ [] + where f1 ds = if dx < 0 && dz > 0 then West:ds else ds + f2 ds = if dx < 0 && dy > 0 then Northwest:ds else ds + f3 ds = if dy > 0 && dz < 0 then Northeast:ds else ds + f4 ds = if dx > 0 && dz < 0 then East:ds else ds + f5 ds = if dx > 0 && dy < 0 then Southeast:ds else ds + f6 ds = if dy < 0 && dz > 0 then Southwest:ds else ds + dx = x2 - x1 + dy = y2 - y1 + z1 = -x1 - y1 + z2 = -x2 - y2 + dz = z2 - z1 + contains _ _ = True + null _ = False + nonNull _ = True + +-- +-- Hexagonal grids with hexagonal tiles +-- + +-- | A hexagonal grid with hexagonal tiles +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction HexHexGrid = HexDirection + indices (HexHexGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedHexGrid + distance = distanceBasedOn UnboundedHexGrid + directionTo = directionToBasedOn UnboundedHexGrid + contains g (x,y) = -s < x && x < s && check + where s = size g + check = if x < 0 + then -s-x < y && y < s + else -s < y && y < s-x + +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,s-1) | k ← [-s+1,-s+2..0]] + northeast = [(k,s-1-k) | k ← [1,2..s-1]] + southeast = [(s-1,k) | k ← [-1,-2..(-s)+1]] + south = [(k,(-s)+1) | k ← [s-2,s-3..0]] + southwest = [(k,(-s)+1-k) | k ← [-1,-2..(-s)+1]] + northwest = [(-s+1,k) | k ← [1,2..s-2]] + centre _ = [(0,0)] + +-- | @'hexHexGrid' s@ returns a grid of hexagonal shape, with +-- sides of length @s@, using hexagonal tiles. If @s@ is nonnegative, the +-- resulting grid will have @3*s*(s-1) + 1@ tiles. Otherwise, the resulting +-- grid will be null and the list of indices will be null. +hexHexGrid ∷ Int → HexHexGrid +hexHexGrid r = HexHexGrid r [(x, y) | x ← [-r+1..r-1], y ← f x] + where f x = if x < 0 then [1-r-x .. r-1] else [1-r .. r-1-x] + +-- +-- Parallelogrammatical grids with hexagonal tiles +-- + +-- | A parallelogramatical grid with hexagonal tiles +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction ParaHexGrid = HexDirection + indices (ParaHexGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedHexGrid + distance = distanceBasedOn UnboundedHexGrid + directionTo = directionToBasedOn UnboundedHexGrid + contains g (x,y) = 0 ≤ x && x < c && 0 ≤ y && y < r + where (r,c) = size g + +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' r c@ returns a grid in the shape of a +-- parallelogram with @r@ rows and @c@ columns, using hexagonal tiles. If +-- @r@ and @c@ are both nonnegative, the resulting grid will have @r*c@ tiles. +-- Otherwise, the resulting grid will be null and the list of indices will +-- be null. +paraHexGrid ∷ Int → Int → ParaHexGrid +paraHexGrid r c = + ParaHexGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] + diff --git a/src/Math/Geometry/Grid/Octagonal.hs b/src/Math/Geometry/Grid/Octagonal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/Octagonal.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Geometry.OctGrid +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A regular arrangement of octagonal tiles. +-- Octagons won't tile a regular plane (there will be diamond-shaped +-- gaps between the tiles), but they will tile a /hyperbolic/ plane. +-- (Alternatively, you can think of these as squares on a board game +-- where diagonal moves are allowed.) +-- The userguide, with illustrations, is available at +-- . +-- Also see @Math.Geometry.Grid@ for examples of how to use this class. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances #-} + +module Math.Geometry.Grid.Octagonal + ( + -- * Unbounded grid with octagonal tiles + UnboundedOctGrid, + -- * Rectangular grid with octagonal tiles + RectOctGrid, + rectOctGrid, + -- * Toroidal grid with octagonal tiles + TorOctGrid, + torOctGrid + ) where + +import Math.Geometry.Grid.OctagonalInternal (UnboundedOctGrid, RectOctGrid, + rectOctGrid, TorOctGrid, torOctGrid) + diff --git a/src/Math/Geometry/Grid/OctagonalInternal.hs b/src/Math/Geometry/Grid/OctagonalInternal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/OctagonalInternal.hs @@ -0,0 +1,139 @@ +------------------------------------------------------------------------ +-- | +-- Module : Math.Geometry.OctGridInternal +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A module containing private @OctGrid@ internals. Most developers +-- should use @OctGrid@ instead. This module is subject to change +-- without notice. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} + +module Math.Geometry.Grid.OctagonalInternal where + +import Prelude hiding (null) + +import Data.List (nub) +import Data.Ord.Unicode ((≤)) +import Math.Geometry.GridInternal + +data OctDirection = West | Northwest | North | Northeast | East | + Southeast | South | Southwest deriving (Show, Eq) + +-- | An unbounded grid with octagonal tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +data UnboundedOctGrid = UnboundedOctGrid deriving Show + +instance Grid UnboundedOctGrid where + type Index UnboundedOctGrid = (Int, Int) + type Direction UnboundedOctGrid = OctDirection + indices _ = undefined + neighbours _ (x,y) = [(x-1,y+1), (x,y+1), (x+1,y+1), (x+1,y), + (x+1,y-1), (x,y-1), (x-1,y-1), (x-1,y)] + distance _ (x1, y1) (x2, y2) = max (abs (x2-x1)) (abs (y2-y1)) + contains _ _ = True + directionTo _ (x1, y1) (x2, y2) = + f1 . f2 . f3 . f4 . f5 . f6 . f7 . f8 $ [] + where f1 ds = if dy > abs dx then North:ds else ds + f2 ds = if -dy > abs dx then South:ds else ds + f3 ds = if dx > abs dy then East:ds else ds + f4 ds = if -dx > abs dy then West:ds else ds + f5 ds = if dx > 0 && dy > 0 then Northeast:ds else ds + f6 ds = if dx > 0 && dy < 0 then Southeast:ds else ds + f7 ds = if dx < 0 && dy < 0 then Southwest:ds else ds + f8 ds = if dx < 0 && dy > 0 then Northwest:ds else ds + dx = x2 - x1 + dy = y2 - y1 + null _ = False + nonNull _ = True + +-- +-- Rectangular grids with octagonal tiles +-- + +-- | A rectangular grid with octagonal tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction RectOctGrid = OctDirection + indices (RectOctGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedOctGrid + distance = distanceBasedOn UnboundedOctGrid + directionTo = directionToBasedOn UnboundedOctGrid + contains g (x,y) = 0 ≤ x && x < c && 0 ≤ y && y < r + where (r,c) = size g + +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' r c@ produces a rectangular grid with @r@ rows +-- and @c@ columns, using octagonal tiles. If @r@ and @c@ are both +-- nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, +-- the resulting grid will be null and the list of indices will be +-- null. +rectOctGrid ∷ Int → Int → RectOctGrid +rectOctGrid r c = + RectOctGrid (r,c) [(x,y) | x ← [0..c-1], y ← [0..r-1]] + +-- +-- Toroidal grids with octagonal tiles. +-- + +-- | A toroidal grid with octagonal tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction TorOctGrid = OctDirection + indices (TorOctGrid _ xs) = xs + neighbours = neighboursWrappedBasedOn UnboundedOctGrid + neighbour = neighbourWrappedBasedOn UnboundedOctGrid + distance = distanceWrappedBasedOn UnboundedOctGrid + directionTo = directionToWrappedBasedOn UnboundedOctGrid + isAdjacent g a b = distance g a b ≤ 1 + contains _ _ = True + +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 + denormalise g a = nub [ (x-c,y+r), (x,y+r), (x+c,y+r), + (x-c,y), (x,y), (x+c,y), + (x-c,y-r), (x,y-r), (x+c,y-r) ] + where (r, c) = size g + (x, y) = normalise g a + +-- | @'torOctGrid' r c@ returns a toroidal grid with @r@ +-- rows and @c@ columns, using octagonal tiles. If @r@ and @c@ are +-- both nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, +-- the resulting grid will be null and the list of indices will be null. +torOctGrid ∷ Int → Int → TorOctGrid +torOctGrid r c = TorOctGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] + diff --git a/src/Math/Geometry/Grid/Square.hs b/src/Math/Geometry/Grid/Square.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/Square.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Geometry.SquareGrid +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A regular arrangement of square tiles. +-- The userguide, with illustrations, is available at +-- . +-- Also see @Math.Geometry.Grid@ for examples of how to use this class. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances #-} + +module Math.Geometry.Grid.Square + ( + -- * Unbounded grid with square tiles + UnboundedSquareGrid, + -- * Rectangular grid with square tiles + RectSquareGrid, + rectSquareGrid, + -- * Toroidal grid with square tiles + TorSquareGrid, + torSquareGrid + ) where + +import Math.Geometry.Grid.SquareInternal (UnboundedSquareGrid, + RectSquareGrid, rectSquareGrid, TorSquareGrid, torSquareGrid) + diff --git a/src/Math/Geometry/Grid/SquareInternal.hs b/src/Math/Geometry/Grid/SquareInternal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/SquareInternal.hs @@ -0,0 +1,137 @@ +------------------------------------------------------------------------ +-- | +-- Module : Math.Geometry.SquareGridInternal +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A module containing private @SquareGrid@ internals. Most developers +-- should use @SquareGrid@ instead. This module is subject to change +-- without notice. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} + +module Math.Geometry.Grid.SquareInternal where + +import Prelude hiding (null) + +import Data.Eq.Unicode ((≠)) +import Data.List (nub) +import Data.Ord.Unicode ((≤)) +import Math.Geometry.GridInternal + +data SquareDirection = North | East | South | West deriving (Show, Eq) + +-- | An unbounded grid with square tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +data UnboundedSquareGrid = UnboundedSquareGrid deriving Show + +instance Grid UnboundedSquareGrid where + type Index UnboundedSquareGrid = (Int, Int) + type Direction UnboundedSquareGrid = SquareDirection + indices _ = undefined + neighbours _ (x,y) = [(x,y+1), (x,y-1), (x+1,y), (x-1,y)] + distance _ (x1, y1) (x2, y2) = abs (x2-x1) + abs (y2-y1) + contains _ _ = True + directionTo _ (x1, y1) (x2, y2) = f1 . f2 . f3 . f4 $ [] + where f1 ds = if y2 > y1 then North:ds else ds + f2 ds = if y2 < y1 then South:ds else ds + f3 ds = if x2 > x1 then East:ds else ds + f4 ds = if x2 < x1 then West:ds else ds + null _ = False + nonNull _ = True + +-- +-- Rectangular grids with square tiles +-- + +-- | A rectangular grid with square tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction RectSquareGrid = SquareDirection + 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 (x2-x1) + dy = signum (y2-y1) + directionTo g x y = if g `contains` x && g `contains` y + then directionTo UnboundedSquareGrid x y + else [] + contains g (x,y) = 0 ≤ x && x < c && 0 ≤ y && y < r + where (r, c) = size g + +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 + +-- | @'rectSquareGrid' r c@ produces a rectangular grid with @r@ rows +-- and @c@ columns, using square tiles. If @r@ and @c@ are both +-- nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, +-- the resulting grid will be null and the list of indices will be +-- null. +rectSquareGrid ∷ Int → Int → RectSquareGrid +rectSquareGrid r c = + RectSquareGrid (r,c) [(x,y) | x ← [0..c-1], y ← [0..r-1]] + +-- +-- Toroidal grids with square tiles. +-- + +-- | A toroidal grid with square tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction TorSquareGrid = SquareDirection + indices (TorSquareGrid _ xs) = xs + neighbours = neighboursWrappedBasedOn UnboundedSquareGrid + neighbour = neighbourWrappedBasedOn UnboundedSquareGrid + distance = distanceWrappedBasedOn UnboundedSquareGrid + directionTo = directionToWrappedBasedOn UnboundedSquareGrid + isAdjacent g a b = distance g a b ≤ 1 + contains _ _ = True + +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 + denormalise g b = nub [ (x-c,y+r), (x,y+r), (x+c,y+r), + (x-c,y), (x,y), (x+c,y), + (x-c,y-r), (x,y-r), (x+c,y-r) ] + where (r, c) = size g + (x, y) = normalise g b + +-- | @'torSquareGrid' r c@ returns a toroidal grid with @r@ +-- rows and @c@ columns, using square tiles. If @r@ and @c@ are +-- both nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, +-- the resulting grid will be null and the list of indices will be null. +torSquareGrid ∷ Int → Int → TorSquareGrid +torSquareGrid r c = TorSquareGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] + diff --git a/src/Math/Geometry/Grid/Triangular.hs b/src/Math/Geometry/Grid/Triangular.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/Triangular.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Geometry.TriGrid +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A regular arrangement of triangular tiles. +-- The userguide, with illustrations, is available at +-- . +-- Also see @Math.Geometry.Grid@ for examples of how to use this class. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE UnicodeSyntax, MultiParamTypeClasses, TypeSynonymInstances, + FlexibleInstances #-} + +module Math.Geometry.Grid.Triangular + ( + -- * Unbounded grid with triangular tiles + UnboundedTriGrid, + -- * Triangular grid with triangular tiles + TriTriGrid, + triTriGrid, + -- * Parallelogram-shaped grid with triangular tiles + ParaTriGrid, + paraTriGrid, + -- * Rectangular grid with triangular tiles + RectTriGrid, + rectTriGrid, + -- * Toroidal grid with triangular tiles + TorTriGrid, + torTriGrid + ) where + +import Math.Geometry.Grid.TriangularInternal (UnboundedTriGrid, TriTriGrid, + triTriGrid, ParaTriGrid, paraTriGrid, RectTriGrid, rectTriGrid, + TorTriGrid, torTriGrid) diff --git a/src/Math/Geometry/Grid/TriangularInternal.hs b/src/Math/Geometry/Grid/TriangularInternal.hs new file mode 100644 --- /dev/null +++ b/src/Math/Geometry/Grid/TriangularInternal.hs @@ -0,0 +1,317 @@ +------------------------------------------------------------------------ +-- | +-- Module : Math.Geometry.TriGridInternal +-- Copyright : (c) Amy de Buitléir 2012 +-- License : BSD-style +-- Maintainer : amy@nualeargais.ie +-- Stability : experimental +-- Portability : portable +-- +-- A module containing private @TriGrid@ internals. Most developers +-- should use @TriGrid@ instead. This module is subject to change +-- without notice. +-- +------------------------------------------------------------------------ +{-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} + +module Math.Geometry.Grid.TriangularInternal where + +import Prelude hiding (null) + +import Data.Eq.Unicode ((≡)) +import Data.List (nub) +import Data.Ord.Unicode ((≤), (≥)) +import Math.Geometry.GridInternal + +data TriDirection = South | Northwest | Northeast | + North | Southeast | Southwest deriving (Show, Eq) + +-- | An unbounded grid with triangular tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +data UnboundedTriGrid = UnboundedTriGrid deriving Show + +instance Grid UnboundedTriGrid where + type Index UnboundedTriGrid = (Int, Int) + type Direction UnboundedTriGrid = TriDirection + indices _ = undefined + neighbours _ (x,y) = if even y + then [(x-1,y+1), (x+1,y+1), (x+1,y-1)] + else [(x-1,y-1), (x-1,y+1), (x+1,y-1)] + distance _ (x1, y1) (x2, y2) = + maximum [abs (x2-x1), abs (y2-y1), abs(z2-z1)] + where z1 = triZ x1 y1 + z2 = triZ x2 y2 + contains _ _ = True + null _ = False + nonNull _ = True + directionTo _ (x1, y1) (x2, y2) = + if even y1 + then f1 . f2 . f3 $ [] + else f4 . f5 . f6 $ [] + where f1 ds = if y2 < y1 then South:ds else ds + f2 ds = if x2 < x1 then Northwest:ds else ds + f3 ds = if z2 < z1 then Northeast:ds else ds + f4 ds = if y2 > y1 then North:ds else ds + f5 ds = if x2 > x1 then Southeast:ds else ds + f6 ds = if z2 > z1 then Southwest:ds else ds + z1 = triZ x1 y1 + z2 = triZ x2 y2 + + +-- | For triangular tiles, it is convenient to define a third component +-- z. +triZ ∷ Int → Int → Int +triZ x y = if even y then -x - y else -x - y + 1 + +-- +-- Triangular grids with triangular tiles +-- + +-- | A triangular grid with triangular tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction TriTriGrid = TriDirection + indices (TriTriGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedTriGrid + distance = distanceBasedOn UnboundedTriGrid + contains (TriTriGrid s _) (x, y) = inTriTriGrid (x,y) s + directionTo = directionToBasedOn UnboundedTriGrid + +inTriTriGrid ∷ (Int, Int) → Int → Bool +inTriTriGrid (x, y) s = x ≥ 0 && y ≥ 0 && even (x+y) && abs z ≤ 2*s-2 + 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*s-2]] + east = [(k,2*s-2-k) | k ← [2,4..2*s-2]] + south = [(k,0) | k ← [2*s-4,2*s-6..2]] + centre g = case s `mod` 3 of + 0 → trefoilWithTop (k-1,k+1) where k = (2*s) `div` 3 + 1 → [(k,k)] where k = (2*(s-1)) `div` 3 + 2 → [(k+1,k+1)] where k = (2*(s-2)) `div` 3 + _ → error "This will never happen." + where s = size g + trefoilWithTop (i,j) = [(i,j), (i+2, j-2), (i,j-2)] + +-- | @'triTriGrid' s@ returns a triangular grid with sides of +-- length @s@, using triangular tiles. If @s@ is nonnegative, the +-- resulting grid will have @s^2@ tiles. Otherwise, the resulting grid +-- will be null and the list of indices will be null. +triTriGrid ∷ Int → TriTriGrid +triTriGrid s = + TriTriGrid s [(xx,yy) | xx ← [0..2*(s-1)], + yy ← [0..2*(s-1)], + (xx,yy) `inTriTriGrid` s] + +-- +-- Parallelogrammatical grids with triangular tiles +-- + +-- | A Parallelogrammatical grid with triangular tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction ParaTriGrid = TriDirection + indices (ParaTriGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedTriGrid + distance = distanceBasedOn UnboundedTriGrid + directionTo = directionToBasedOn UnboundedTriGrid + contains g (x,y) = 0 ≤ x && x < 2*c && 0 ≤ y && y < 2*r && even (x+y) + where (r,c) = size g + +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*r-2], c>0] + north = [(k,2*r-1) | k ← [1,3..2*c-1], r>0] + east = [(2*c-1,k) | k ← [2*r-3,2*r-5..1], c>0] + south = [(k,0) | k ← [2*c-2,2*c-4..2], r>0] + centre g = f . size $ g + where f (r,c) + | odd r && odd c + = [(c-1,r-1), (c,r)] + | even r && even c && r ≡ c + = bowtie (c-1,r-1) + | even r && even c && r > c + = bowtie (c-1,r-3) ++ bowtie (c-1,r-1) ++ bowtie (c-1,r+1) + | even r && even c && r < c + = bowtie (c-3,r-1) ++ bowtie (c-1,r-1) ++ bowtie (c+1,r-1) + | otherwise + = [(c-1,r), (c,r-1)] + bowtie (i,j) = [(i,j), (i+1,j+1)] + +-- | @'paraTriGrid' r c@ returns a grid in the shape of a +-- parallelogram with @r@ rows and @c@ columns, using triangular +-- tiles. If @r@ and @c@ are both nonnegative, the resulting grid will +-- have @2*r*c@ tiles. Otherwise, the resulting grid will be null and +-- the list of indices will be null. +paraTriGrid ∷ Int → Int → ParaTriGrid +paraTriGrid r c = + ParaTriGrid (r,c) [(x,y) | x ← [0..2*c-1], y ← [0..2*r-1], even (x+y)] + + +-- +-- Rectangular grids with triangular tiles +-- + +-- | A rectangular grid with triangular tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction RectTriGrid = TriDirection + indices (RectTriGrid _ xs) = xs + neighbours = neighboursBasedOn UnboundedTriGrid + distance = distanceBasedOn UnboundedTriGrid + directionTo = directionToBasedOn UnboundedTriGrid + -- TODO Implement faster "contains" + +instance FiniteGrid RectTriGrid where + type Size RectTriGrid = (Int, Int) + size (RectTriGrid s _) = s + +instance BoundedGrid RectTriGrid where + tileSideCount _ = 3 + +-- | @'rectTriGrid' r c@ returns a grid in the shape of a +-- rectangle (with jagged edges) that has @r@ rows and @c@ columns, +-- using triangular tiles. If @r@ and @c@ are both nonnegative, the +-- resulting grid will have @2*r*c@ tiles. Otherwise, the resulting grid will be null and +-- the list of indices will be null. +rectTriGrid ∷ Int → Int → RectTriGrid +rectTriGrid r c = RectTriGrid (r,c) [(x,y) | y ← [0..2*r-1], 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*(c2-1) + + +-- +-- Toroidal grids with triangular tiles +-- + +-- | A toroidal grid with triangular tiles. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +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) + type Direction TorTriGrid = TriDirection + indices (TorTriGrid _ xs) = xs + neighbours = neighboursWrappedBasedOn UnboundedTriGrid + neighbour = neighbourWrappedBasedOn UnboundedTriGrid + distance = distanceWrappedBasedOn UnboundedTriGrid + directionTo = directionToWrappedBasedOn UnboundedTriGrid + isAdjacent g a b = distance g a b ≤ 1 + contains _ _ = True + +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 (x,y+2*r) + | y > 2*r-1 = normalise g (x,y-2*r) + | x < 0 = normalise g (x+2*c,y) + | x > 2*c-1 = normalise g (x-2*c,y) + | otherwise = (x,y) + where (r, c) = size g + denormalise g a = nub [ (x-2*c,y+2*r), (x,y+2*r), (x+2*c,y+2*r), + (x-2*c,y), (x,y), (x+2*c,y), + (x-2*c,y-2*r), (x,y-2*r), (x+2*c,y-2*r) ] + where (r, c) = size g + (x, y) = normalise g a + +-- | @'torTriGrid' r c@ returns a toroidal grid with @r@ rows and @c@ +-- columns, using triangular tiles. The indexing method is the same as +-- for @ParaTriGrid@. If @r@ and @c@ are both nonnegative, the +-- resulting grid will have @2*r*c@ tiles. Otherwise, the resulting +-- grid will be null and the list of indices will be null. +torTriGrid ∷ Int → Int → TorTriGrid +torTriGrid r c = + TorTriGrid (r,c) [(x,y) | x ← [0..2*c-1], y ← [0..2*r-1], even (x+y)] + +-- +-- Cylindrical grids with triangular tiles +-- + +-- | A cylindrical grid with triangular tiles, where the cylinder is +-- along the y-axis. +-- The grid and its indexing scheme are illustrated in the user guide, +-- available at . +data YCylTriGrid = YCylTriGrid (Int, Int) [(Int, Int)] deriving Eq + +instance Show YCylTriGrid where + show (YCylTriGrid (r,c) _) = "yCylTriGrid " ++ show r ++ " " ++ show c + +instance Grid YCylTriGrid where + type Index YCylTriGrid = (Int, Int) + type Direction YCylTriGrid = TriDirection + indices (YCylTriGrid _ xs) = xs + neighbours = neighboursWrappedBasedOn UnboundedTriGrid + neighbour = neighbourWrappedBasedOn UnboundedTriGrid + distance = distanceWrappedBasedOn UnboundedTriGrid + directionTo = directionToWrappedBasedOn UnboundedTriGrid + isAdjacent g a b = distance g a b ≤ 1 + contains g (x, y) = 0 ≤ y && y ≤ 2*r-1 && even (x+y) + where (r, _) = size g + +instance FiniteGrid YCylTriGrid where + type Size YCylTriGrid = (Int, Int) + size (YCylTriGrid s _) = s + +instance WrappedGrid YCylTriGrid where + normalise g (x,y) | x < 0 = normalise g (x+2*c,y) + | x > 2*c-1 = normalise g (x-2*c,y) + | otherwise = (x,y) + where (_, c) = size g + denormalise g a = nub [ (x-2*c,y), (x,y), (x+2*c,y) ] + where (_, c) = size g + (x, y) = normalise g a + +-- | @'yCylTriGrid' r c@ returns a cylindrical grid with @r@ rows and +-- @c@ columns, using triangular tiles, where the cylinder is along +-- the y-axis. The indexing method is the same as for @ParaTriGrid@. +-- If @r@ and @c@ are both nonnegative, the resulting grid will have +-- @2*r*c@ tiles. Otherwise, the resulting grid will be null and the +-- list of indices will be null. +yCylTriGrid ∷ Int → Int → YCylTriGrid +yCylTriGrid r c = + YCylTriGrid (r,c) [(x,y) | x ← [0..2*c-1], y ← [0..2*r-1], even (x+y)] + + + diff --git a/src/Math/Geometry/GridInternal.hs b/src/Math/Geometry/GridInternal.hs --- a/src/Math/Geometry/GridInternal.hs +++ b/src/Math/Geometry/GridInternal.hs @@ -13,50 +13,21 @@ ------------------------------------------------------------------------ {-# LANGUAGE UnicodeSyntax, TypeFamilies, FlexibleContexts #-} -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 +module Math.Geometry.GridInternal where import Prelude hiding (null) -import Data.Eq.Unicode ((≡), (≠)) +import Data.Eq.Unicode ((≡)) import Data.Function (on) import Data.List (groupBy, nub, nubBy, sortBy) import Data.Ord (comparing) -import Data.Ord.Unicode ((≤), (≥)) -- | A regular arrangement of tiles. --- Minimal complete definition: @Index@, @indices@ and @distance@. +-- 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] @@ -75,29 +46,28 @@ -- any of @bs@ are not contained within @g@, the result is -- undefined. minDistance ∷ g → [Index g] → Index g → Int - minDistance g xs x = minimum . map (distance g x) $ xs + minDistance = defaultMinDistance - -- | @'neighbours' g x@ returns the indices of the tiles in the grid - -- @g@ which are adjacent to the tile with index @x@. + -- | @'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 g x = filter (\a → distance g x a ≡ 1 ) $ indices g + neighbours = defaultNeighbours - -- | @'numNeighbours' g x@ returns the number of tiles in the grid - -- @g@ which are adjacent to the tile with index @x@. + -- | @'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'` x@ returns @True@ if the index @x@ is contained + -- | @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 x = x `elem` indices g - - -- | @'viewpoint' g x@ returns a list of pairs associating the index - -- of each tile in @g@ with its distance to the tile with index @x@. - -- If @x@ 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 x = (x, distance g p x) + contains g a = a `elem` indices g -- | Returns the number of tiles in a grid. Compare with @'size'@. tileCount ∷ g → Int @@ -116,14 +86,21 @@ -- | 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 g = nubBy sameEdge $ concatMap (`adjacentEdges` g) $ indices 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 ∷ Eq (Index g) ⇒ g → Index g → Index g → Bool - isAdjacent g a b = a `elem` (neighbours g b) + 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 @@ -132,8 +109,7 @@ -- 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 g a b = filter f $ neighbours g a - where f x = distance g x b ≡ distance g a b - 1 + 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 @@ -147,19 +123,79 @@ -- consider modifying @'adjacentTilesToward'@ instead of -- @'minimalPaths'@. 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 + 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 @@ -179,596 +215,105 @@ -- | 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 (\y → (y, numNeighbours g y)) $ indices g + where xds = map (\b → (b, numNeighbours g b)) $ indices g f (_,n) = n < tileSideCount g - -- | @'isBoundary' g x@' returns @True@ if the tile with index @x@ is + -- | @'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 x = x `elem` boundary g + 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 . head . reverse . groupBy ((≡) `on` snd) . + centre g = map fst . last . groupBy ((≡) `on` snd) . sortBy (comparing snd) $ xds - where xds = map (\y → (y, minDistance g bs y)) $ indices g + where xds = map (\b → (b, minDistance g bs b)) $ indices g bs = boundary g - -- | @'isCentre' g x@' returns @True@ if the tile with index @x@ is + -- | @'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 x = x `elem` centre g + 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] --- Calculate the neighbours of a tile in a bounded grid by as we would --- in an unbounded grid, but then filter out the tiles that are not in --- bounds. neighboursBasedOn - ∷ (Eq (Index g), Grid u, Grid g, Index u ~ Index g) ⇒ - g → u → Index g → [Index g] + ∷ (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 --- Calculate the distance between two tiles in a bounded grid by as we --- would in an unbounded grid, but only if both tiles are in bounds. distanceBasedOn - ∷ (Eq (Index g), Grid u, Grid g, Index u ~ Index g) ⇒ - g → u → Index g → Index g → Int + ∷ (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 --- --- Triangular tiles --- - --- | An unbounded grid with triangular tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -data UnboundedTriGrid = UnboundedTriGrid deriving Show - -instance Grid UnboundedTriGrid where - type Index UnboundedTriGrid = (Int, Int) - indices _ = undefined - neighbours _ (x,y) = if even y - then [(x-1,y+1), (x+1,y+1), (x+1,y-1)] - else [(x-1,y-1), (x-1,y+1), (x+1,y-1)] - distance _ (x1, y1) (x2, y2) = - maximum [abs (x2-x1), abs (y2-y1), abs(z2-z1)] - where z1 = triZ x1 y1 - z2 = triZ x2 y2 - contains _ _ = True - --- | For triangular tiles, it is convenient to define a third component --- z. -triZ ∷ Int → Int → Int -triZ x y = if even y then -x - y else -x - y + 1 - --- --- Triangular grids with triangular tiles --- - --- | A triangular grid with triangular tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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*s-2 - 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*s-2]] - east = [(k,2*s-2-k) | k ← [2,4..2*s-2]] - south = [(k,0) | k ← [2*s-4,2*s-6..2]] - centre g = case s `mod` 3 of - 0 → trefoilWithTop (k-1,k+1) where k = (2*s) `div` 3 - 1 → [(k,k)] where k = (2*(s-1)) `div` 3 - 2 → [(k+1,k+1)] where k = (2*(s-2)) `div` 3 - _ → error "This will never happen." - where s = size g - trefoilWithTop (i,j) = [(i,j), (i+2, j-2), (i,j-2)] - --- | @'triTriGrid' s@ returns a triangular grid with sides of --- length @s@, using triangular tiles. If @s@ is nonnegative, the --- resulting grid will have @s^2@ tiles. Otherwise, the resulting grid --- will be null and the list of indices will be null. -triTriGrid ∷ Int → TriTriGrid -triTriGrid s = - TriTriGrid s [(xx,yy) | xx ← [0..2*(s-1)], - yy ← [0..2*(s-1)], - (xx,yy) `inTriTriGrid` s] - --- --- Parallelogrammatical grids with triangular tiles --- - --- | A Parallelogrammatical grid with triangular tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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*r-2], c>0] - north = [(k,2*r-1) | k ← [1,3..2*c-1], r>0] - east = [(2*c-1,k) | k ← [2*r-3,2*r-5..1], c>0] - south = [(k,0) | k ← [2*c-2,2*c-4..2], r>0] - centre g = f . size $ g - where f (r,c) - | odd r && odd c - = [(c-1,r-1), (c,r)] - | even r && even c && r ≡ c - = bowtie (c-1,r-1) - | even r && even c && r > c - = bowtie (c-1,r-3) ++ bowtie (c-1,r-1) ++ bowtie (c-1,r+1) - | even r && even c && r < c - = bowtie (c-3,r-1) ++ bowtie (c-1,r-1) ++ bowtie (c+1,r-1) - | otherwise - = [(c-1,r), (c,r-1)] - bowtie (i,j) = [(i,j), (i+1,j+1)] - --- | @'paraTriGrid' r c@ returns a grid in the shape of a --- parallelogram with @r@ rows and @c@ columns, using triangular --- tiles. If @r@ and @c@ are both nonnegative, the resulting grid will --- have @2*r*c@ tiles. Otherwise, the resulting grid will be null and --- the list of indices will be null. -paraTriGrid ∷ Int → Int → ParaTriGrid -paraTriGrid r c = - ParaTriGrid (r,c) [(x,y) | x ← [0..2*c-1], y ← [0..2*r-1], even (x+y)] - - --- --- Rectangular grids with triangular tiles --- - --- | A rectangular grid with triangular tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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' r c@ returns a grid in the shape of a --- rectangle (with jagged edges) that has @r@ rows and @c@ columns, --- using triangular tiles. If @r@ and @c@ are both nonnegative, the --- resulting grid will have @2*r*c@ tiles. Otherwise, the resulting grid will be null and --- the list of indices will be null. -rectTriGrid ∷ Int → Int → RectTriGrid -rectTriGrid r c = RectTriGrid (r,c) [(x,y) | y ← [0..2*r-1], 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*(c2-1) - - --- --- Toroidal grids with triangular tiles --- - --- | A toroidal grid with triangular tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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) +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 -instance FiniteGrid TorTriGrid where - type Size TorTriGrid = (Int, Int) - size (TorTriGrid s _) = s +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 -instance WrappedGrid TorTriGrid where - normalise g (x,y) - | y < 0 = normalise g (x-r,y+2*r) - | y > 2*r-1 = normalise g (x+r,y-2*r) - | x < xMin = normalise g (x+2*c,y) - | x > xMin + 2*c-1 = normalise g (x-2*c,y) - | otherwise = (x,y) - where xMin = xMinTorTri y - (r, c) = size g +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 --- | @'torTriGrid' r c@ returns a toroidal grid with @r@ rows and @c@ --- columns, using triangular tiles. If @r@ is odd, the result is --- undefined because the grid edges would overlap. If @r@ and @c@ --- are both nonnegative, the resulting grid will have @2*r*c@ tiles. --- Otherwise, the resulting grid will be null and the list of indices --- will be null. -torTriGrid ∷ Int → Int → TorTriGrid -torTriGrid r c = - if even r - then TorTriGrid (r,c) [(x,y) | y ← [0..2*r-1], - x ← [xMinTorTri y .. xMax c y], - even (x+y)] +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 xMax c2 y = xMinTorTri y + 2*(c2-1) + where a' = normalise g a + ys = denormalise g b + minD = distance g a b + ys' = filter (\c -> distance u a' c == minD) ys --- --- Square tiles --- --- | An unbounde grid with square tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -data UnboundedSquareGrid = UnboundedSquareGrid deriving Show - -instance Grid UnboundedSquareGrid where - type Index UnboundedSquareGrid = (Int, Int) - indices _ = undefined - neighbours _ (x,y) = [(x,y+1), (x,y-1), (x+1,y), (x-1,y)] - distance _ (x1, y1) (x2, y2) = abs (x2-x1) + abs (y2-y1) - contains _ _ = True - --- --- Rectangular grids with square tiles --- - --- | A rectangular grid with square tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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 (x2-x1) - dy = signum (y2-y1) - -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..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 ← midpoints c, j ← midpoints r] - -midpoints ∷ Int → [Int] -midpoints k = if even k then [m-1,m] else [m] - where m = floor (k'/2.0) - k' = fromIntegral k ∷ Double - --- | @'rectSquareGrid' r c@ produces a rectangular grid with @r@ rows --- and @c@ columns, using square tiles. If @r@ and @c@ are both --- nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, --- the resulting grid will be null and the list of indices will be --- null. -rectSquareGrid ∷ Int → Int → RectSquareGrid -rectSquareGrid r c = - RectSquareGrid (r,c) [(x,y) | x ← [0..c-1], y ← [0..r-1]] - --- --- Toroidal grids with square tiles. --- - --- | A toroidal grid with square tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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 (TorSquareGrid (r,c) _) (x,y) = --- nub $ filter (\(xx,yy) → xx ≠ x || yy ≠ y) --- [((x-1) `mod` c,y), (x,(y+1) `mod` r), ((x+1) `mod` c,y), --- (x,(y-1) `mod` r)] - neighbours g = nub . map (normalise g) . neighbours UnboundedSquareGrid - distance g@(TorSquareGrid (r,c) _) (x1, y1) (x2, y2) = -- TODO redo - if g `contains` (x1, y1) && g `contains` (x2, y2) - then min adx (abs (c-adx)) + min ady (abs (r-ady)) - 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' r c@ returns a toroidal grid with @r@ --- rows and @c@ columns, using square tiles. If @r@ and @c@ are --- both nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, --- the resulting grid will be null and the list of indices will be null. -torSquareGrid ∷ Int → Int → TorSquareGrid -torSquareGrid r c = TorSquareGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] - --- --- Hexagonal tiles --- - --- | An unbounded grid with hexagonal tiles --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -data UnboundedHexGrid = UnboundedHexGrid deriving Show - -instance Grid UnboundedHexGrid where - type Index UnboundedHexGrid = (Int, Int) - indices _ = undefined - neighbours _ (x,y) = - [(x-1,y), (x-1,y+1), (x,y+1), (x+1,y), (x+1,y-1), (x,y-1)] - distance _ (x1, y1) (x2, y2) = - maximum [abs (x2-x1), abs (y2-y1), abs(z2-z1)] - where z1 = -x1 - y1 - z2 = -x2 - y2 - contains _ _ = True - --- --- Hexagonal grids with hexagonal tiles --- - --- | A hexagonal grid with hexagonal tiles --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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,s-1) | k ← [-s+1,-s+2..0]] - northeast = [(k,s-1-k) | k ← [1,2..s-1]] - southeast = [(s-1,k) | k ← [-1,-2..(-s)+1]] - south = [(k,(-s)+1) | k ← [s-2,s-3..0]] - southwest = [(k,(-s)+1-k) | k ← [-1,-2..(-s)+1]] - northwest = [(-s+1,k) | k ← [1,2..s-2]] - centre _ = [(0,0)] - --- | @'hexHexGrid' s@ returns a grid of hexagonal shape, with --- sides of length @s@, using hexagonal tiles. If @s@ is nonnegative, the --- resulting grid will have @3*s*(s-1) + 1@ tiles. Otherwise, the resulting --- grid will be null and the list of indices will be null. -hexHexGrid ∷ Int → HexHexGrid -hexHexGrid r = HexHexGrid r [(x, y) | x ← [-r+1..r-1], y ← f x] - where f x = if x < 0 then [1-r-x .. r-1] else [1-r .. r-1-x] - --- --- Parallelogrammatical grids with hexagonal tiles --- - --- | A parallelogramatical grid with hexagonal tiles --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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' r c@ returns a grid in the shape of a --- parallelogram with @r@ rows and @c@ columns, using hexagonal tiles. If --- @r@ and @c@ are both nonnegative, the resulting grid will have @r*c@ tiles. --- Otherwise, the resulting grid will be null and the list of indices will --- be null. -paraHexGrid ∷ Int → Int → ParaHexGrid -paraHexGrid r c = - ParaHexGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] - - --- --- Octagonal tiles --- - --- | An unbounded grid with octagonal tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -data UnboundedOctGrid = UnboundedOctGrid deriving Show - -instance Grid UnboundedOctGrid where - type Index UnboundedOctGrid = (Int, Int) - indices _ = undefined - neighbours _ (x,y) = [(x-1,y+1), (x,y+1), (x+1,y+1), (x+1,y), - (x+1,y-1), (x,y-1), (x-1,y-1), (x-1,y)] - distance _ (x1, y1) (x2, y2) = max (abs (x2-x1)) (abs (y2-y1)) - contains _ _ = True - --- --- Rectangular grids with octagonal tiles --- - --- | A rectangular grid with octagonal tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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' r c@ produces a rectangular grid with @r@ rows --- and @c@ columns, using octagonal tiles. If @r@ and @c@ are both --- nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, --- the resulting grid will be null and the list of indices will be --- null. -rectOctGrid ∷ Int → Int → RectOctGrid -rectOctGrid r c = - RectOctGrid (r,c) [(x,y) | x ← [0..c-1], y ← [0..r-1]] - --- --- Toroidal grids with octagonal tiles. --- - --- | A toroidal grid with octagonal tiles. --- The grid and its indexing scheme are illustrated in the user guide, --- available at . -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' r c@ returns a toroidal grid with @r@ --- rows and @c@ columns, using octagonal tiles. If @r@ and @c@ are --- both nonnegative, the resulting grid will have @r*c@ tiles. Otherwise, --- the resulting grid will be null and the list of indices will be null. -torOctGrid ∷ Int → Int → TorOctGrid -torOctGrid r c = TorOctGrid (r,c) [(x, y) | x ← [0..c-1], y ← [0..r-1]] diff --git a/src/Math/Geometry/GridMap/Lazy.hs b/src/Math/Geometry/GridMap/Lazy.hs --- a/src/Math/Geometry/GridMap/Lazy.hs +++ b/src/Math/Geometry/GridMap/Lazy.hs @@ -60,11 +60,13 @@ instance G.Grid g ⇒ G.Grid (LGridMap g v) where type Index (LGridMap g v) = G.Index g + type Direction (LGridMap g v) = G.Direction g indices = G.indices . lgmGrid distance g = G.distance (lgmGrid g) + directionTo g = G.directionTo (lgmGrid g) neighbours g k = lgmGrid g `G.neighbours` k contains g k = lgmGrid g `G.contains` k - viewpoint g k = lgmGrid g `G.viewpoint` k +-- viewpoint g k = lgmGrid g `G.viewpoint` k tileCount = G.tileCount . lgmGrid null = G.null . lgmGrid nonNull = G.nonNull . lgmGrid diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,14 +1,20 @@ {-# LANGUAGE UnicodeSyntax #-} module Main where -import Math.Geometry.GridQC ( test ) +import Math.Geometry.Grid.TriangularQC ( test ) +import Math.Geometry.Grid.SquareQC ( test ) +import Math.Geometry.Grid.HexagonalQC ( test ) +import Math.Geometry.Grid.OctagonalQC ( test ) import Test.Framework as TF ( defaultMain, Test ) tests ∷ [TF.Test] tests = [ - Math.Geometry.GridQC.test + Math.Geometry.Grid.TriangularQC.test, + Math.Geometry.Grid.SquareQC.test, + Math.Geometry.Grid.HexagonalQC.test, + Math.Geometry.Grid.OctagonalQC.test ] main ∷ IO () diff --git a/test/Math/Geometry/GridQC.hs b/test/Math/Geometry/GridQC.hs --- a/test/Math/Geometry/GridQC.hs +++ b/test/Math/Geometry/GridQC.hs @@ -1,1059 +1,353 @@ {-# LANGUAGE UnicodeSyntax, FlexibleContexts, ExistentialQuantification, - TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Math.Geometry.GridQC - ( - test - ) where - -import Math.Geometry.GridInternal - -import Prelude hiding (null) -import qualified Prelude as P (null) -import Data.Eq.Unicode ((≡), (≠)) -import Data.List (delete, nub, sort) -import Data.Ord.Unicode ((≤)) -import qualified Math.Combinatorics.Exact.Binomial as M (choose) -import Test.Framework as TF (Test, testGroup) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.QuickCheck - ((==>), Gen, Arbitrary, arbitrary, sized, choose, Property, property) - --- | @'isqrt' n@ returns the greatest integer not greater than the square root --- of @n@. -isqrt ∷ Int → Int -isqrt n = (floor . sqrt) n' - where n' = fromIntegral n ∷ Float - --- Given an arbitrary integer, select a corresponding point in the grid. -pointAt ∷ Grid g ⇒ g → Int → Index g -pointAt g i = indices g !! (i `mod` n) - where n = (length . indices) g - -minPathCount - ∷ (Eq (Index g), Grid g) ⇒ g → Index g → Index g → Int -minPathCount g a b = length . minimalPaths g a $ b - -minPathCount2 - ∷ (Eq (Index g), Grid g) ⇒ g → [Index g] → Index g → Int -minPathCount2 g as b = sum . map (\x → minPathCount g x b) $ as - -neighbourCount ∷ ∀ g. Grid g ⇒ g → Index g → Int -neighbourCount g x = length . neighbours g $ x - --- --- Tests that should apply to and are identical for all grids --- - -prop_distance_reflexive ∷ Grid g ⇒ g → Int → Property -prop_distance_reflexive g i = nonNull g ==> distance g a a ≡ 0 - where a = g `pointAt` i - -prop_distance_symmetric ∷ Grid g ⇒ g → Int → Int → Property -prop_distance_symmetric g i j = - nonNull g ==> distance g a b ≡ distance g b a - where a = g `pointAt` i - b = g `pointAt` j - --- "cw" = "consistent with" - -prop_minDistance_cw_distance ∷ Grid g ⇒ g → Int → [Int] → Property -prop_minDistance_cw_distance g i js = - nonNull g && (not . P.null) js ==> - minDistance g (b:bs) a ≤ distance g b a - where a = g `pointAt` i - (b:bs) = map (g `pointAt`) js - -prop_neighbours_cw_viewpoint - ∷ (Grid g, Ord (Index g)) ⇒ - g → Int → Property -prop_neighbours_cw_viewpoint g i = nonNull g ==> - sort (delete a (neighbours g a)) ≡ sort expected - where a = g `pointAt` i - expected = map fst $ filter (\p → 1 ≡ snd p) $ viewpoint g a --- Note: In a small but unbounded grid, a tile can be its own neighbour. --- However, when we calculate the distance between a tile and itself, we --- get 0, not 1. That's why we have to delete the tile from its list --- before comparing to the result from the neighbours function. - -prop_edges_cw_neighbours ∷ (Grid g, Ord (Index g)) ⇒ g → Int → Property -prop_edges_cw_neighbours g i = nonNull g ==> - sort (neighbours g a) ≡ sort expected - where a = g `pointAt` i - nEdges = filter (`involves` a) $ edges g - expected = map f nEdges - f (b,c) = if a ≡ b then c else b - -involves ∷ Eq a ⇒ (a, a) → a → Bool -involves (a, b) c = c ≡ a || c ≡ b - -prop_edges_are_adjacent ∷ (Grid g, Ord (Index g)) ⇒ g → Property -prop_edges_are_adjacent g = property $ all f $ edges g - where f (a, b) = isAdjacent g a b - -prop_adjacentTilesToward_moves_closer - ∷ (Grid g, Eq (Index g)) ⇒ g → Int → Int → Property -prop_adjacentTilesToward_moves_closer g i j = nonNull g && a ≠ b ==> - ns ≡ [d-1] - where a = g `pointAt` i - b = g `pointAt` j - d = distance g a b - ns = nub $ map (\x → distance g x b) $ adjacentTilesToward g a b - -prop_minimal_paths_have_min_length - ∷ (Grid g, Eq (Index g)) ⇒ g → Int → Int → Property -prop_minimal_paths_have_min_length g i j = nonNull g ==> ns ≡ [d+1] - where a = g `pointAt` i - b = g `pointAt` j - d = distance g a b - ns = nub $ map length $ minimalPaths g a b - -prop_minimal_paths_are_valid - ∷ (Grid g, Eq (Index g)) ⇒ g → Int → Int → Property -prop_minimal_paths_are_valid g i j = nonNull g ==> - and $ map (subsequentTilesInPathAreAdjacent g) $ minimalPaths g a b - where a = g `pointAt` i - b = g `pointAt` j - -subsequentTilesInPathAreAdjacent - ∷ (Grid g, Eq (Index g)) ⇒ g → [Index g] → Bool -subsequentTilesInPathAreAdjacent _ [] = True -subsequentTilesInPathAreAdjacent g [x] = x `elem` indices g -subsequentTilesInPathAreAdjacent g (a:b:xs) = - isAdjacent g a b && subsequentTilesInPathAreAdjacent g (b:xs) - --- --- Tests that should apply to and are identical for all bounded grids --- - -prop_grid_and_boundary_are_both_null_or_not - ∷ BoundedGrid g ⇒ g → Property -prop_grid_and_boundary_are_both_null_or_not g = property $ - (P.null . boundary) g ≡ null g - -prop_boundary_in_grid ∷ (BoundedGrid g, Eq (Index g)) ⇒ g → Property -prop_boundary_in_grid g = property $ - all (g `contains`) . boundary $ g - -prop_boundary_tiles_have_fewer_neighbours - ∷ BoundedGrid g ⇒ g → Int → Property -prop_boundary_tiles_have_fewer_neighbours g i = nonNull g ==> - g `numNeighbours` b ≤ g `numNeighbours` a - where a = g `pointAt` i - (b:_) = boundary g - -prop_centres_equidistant_from_boundary ∷ BoundedGrid g ⇒ g → Property -prop_centres_equidistant_from_boundary g = nonNull g ==> - (length . nub . map (minDistance g bs)) cs ≡ 1 - where bs = boundary g - cs = centre g - -prop_centres_farthest_from_boundary - ∷ (BoundedGrid g, Eq (Index g)) ⇒ g → Int → Property -prop_centres_farthest_from_boundary g i = - nonNull g && (not . isCentre g) a ==> - minDistance g bs a ≤ minDistance g bs c - where a = g `pointAt` i - (c:_) = centre g - bs = boundary g - --- --- Triangular grids with triangular tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedTriTriGrid ∷ Int → Gen TriTriGrid -sizedTriTriGrid n = return $ triTriGrid (2 * isqrt n) - -instance Arbitrary TriTriGrid where - arbitrary = sized sizedTriTriGrid - -prop_TriTriGrid_tile_count_correct ∷ TriTriGrid → Property -prop_TriTriGrid_tile_count_correct g = property $ - (length . indices) g ≡ if s ≤ 0 then 0 else s*s - where s = size g - -prop_TriTriGrid_distance_in_bounds ∷ TriTriGrid → Int → Int → Property -prop_TriTriGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ 2*(s-1) - where s = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by triTriGrid is ever changed, this property --- may need to be changed too. It relies on the first and last elements being --- at corners. -prop_TriTriGrid_distance_edge_to_edge ∷ TriTriGrid → Property -prop_TriTriGrid_distance_edge_to_edge g = s > 0 ==> distance g a b ≡ 2*(s-1) - where ps = indices g - a = head ps - b = last ps - s = size g - -prop_TriTriGrid_neighbour_count_in_bounds ∷ TriTriGrid → Int → Property -prop_TriTriGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 3 - where x = g `pointAt` i - -prop_TriTriGrid_boundary_count_correct ∷ TriTriGrid → Property -prop_TriTriGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (f . size) g - where f 0 = 0 - f 1 = 1 - f s = 3*(s-1) - -prop_TriTriGrid_boundary_tiles_have_fewer_neighbours ∷ TriTriGrid → Property -prop_TriTriGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (3>) . map (numNeighbours g) . boundary $ g - --- --- Parallelogram-shaped grids with triangular tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedParaTriGrid ∷ Int → Gen ParaTriGrid -sizedParaTriGrid n = do - r ← choose (0,n) - let c = n `div` (2*r + 1) - return $ paraTriGrid r c - -instance Arbitrary ParaTriGrid where - arbitrary = sized sizedParaTriGrid - -prop_ParaTriGrid_tile_count_correct ∷ ParaTriGrid → Property -prop_ParaTriGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else 2*r*c - where (r, c) = size g - -prop_ParaTriGrid_distance_in_bounds ∷ ParaTriGrid → Int → Int → Property -prop_ParaTriGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ 2*(r+c) - 3 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by paraTriGrid is ever changed, this --- property may need to be changed too. It relies on the first and last --- elements being at corners. -prop_ParaTriGrid_distance_corner_to_corner ∷ ParaTriGrid → Property -prop_ParaTriGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - distance g a b ≡ 2*(r+c) - 3 - where ps = indices g - a = head ps - b = last ps - (r, c) = size g - -prop_ParaTriGrid_neighbour_count_in_bounds ∷ ParaTriGrid → Int → Property -prop_ParaTriGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 3 - where x = g `pointAt` i - -prop_ParaTriGrid_boundary_count_correct ∷ ParaTriGrid → Property -prop_ParaTriGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (f . size) g - where f (0,_) = 0 - f (_,0) = 0 - f (1,c) = 2*c - f (r,1) = 2*r - f (r,c) = 2*(r+c-1) - -prop_ParaTriGrid_boundary_tiles_have_fewer_neighbours ∷ ParaTriGrid → Property -prop_ParaTriGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (3>) . map (numNeighbours g) . boundary $ g - --- --- Rectangular grids with triangular tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedRectTriGrid ∷ Int → Gen RectTriGrid -sizedRectTriGrid n = do - r ← choose (0,n) - let c = n `div` (2*r + 1) - return $ rectTriGrid r c - -instance Arbitrary RectTriGrid where - arbitrary = sized sizedRectTriGrid - -prop_RectTriGrid_tile_count_correct ∷ RectTriGrid → Property -prop_RectTriGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else 2*r*c - where (r, c) = size g - -prop_RectTriGrid_distance_in_bounds ∷ RectTriGrid → Int → Int → Property -prop_RectTriGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ 2*(r+c) - 3 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - -prop_RectTriGrid_neighbour_count_in_bounds ∷ RectTriGrid → Int → Property -prop_RectTriGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 3 - where x = g `pointAt` i - -prop_RectTriGrid_boundary_count_correct ∷ RectTriGrid → Property -prop_RectTriGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (f . size) g - where f (0,_) = 0 - f (_,0) = 0 - f (1,c) = 2*c - f (r,1) = 2*r - f (r,c) = 2*(r+c-1) - -prop_RectTriGrid_boundary_tiles_have_fewer_neighbours ∷ RectTriGrid → Property -prop_RectTriGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (3>) . map (numNeighbours g) . boundary $ g - --- --- Toroidal grids with triangular tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedTorTriGrid ∷ Int → Gen TorTriGrid -sizedTorTriGrid n = do - r0 ← choose (0,n `div` 2) - let r = 2*r0 - let c = n `div` (2*r + 1) - return $ torTriGrid r c - -instance Arbitrary TorTriGrid where - arbitrary = sized sizedTorTriGrid - -prop_TorTriGrid_tile_count_correct ∷ TorTriGrid → Property -prop_TorTriGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else 2*r*c - where (r, c) = size g - -prop_TorTriGrid_distance_in_bounds ∷ TorTriGrid → Int → Int → Property -prop_TorTriGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ 2*(r+c) - 3 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - -prop_TorTriGrid_neighbour_count_in_bounds ∷ TorTriGrid → Int → Property -prop_TorTriGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 3 - where x = g `pointAt` i - --- --- Rectangular grids with square tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedRectSquareGrid ∷ Int → Gen RectSquareGrid -sizedRectSquareGrid n = do - r ← choose (0,n) - let c = n `div` (r+1) - return $ rectSquareGrid r c - -instance Arbitrary RectSquareGrid where - arbitrary = sized sizedRectSquareGrid - -prop_RectSquareGrid_tile_count_correct ∷ RectSquareGrid → Property -prop_RectSquareGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else r*c - where (r, c) = size g - -prop_RectSquareGrid_distance_in_bounds ∷ RectSquareGrid → Int → Int → Property -prop_RectSquareGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ r + c - 2 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by rectSquareGrid is ever changed, this --- property may need to be changed too. It relies on the first and last --- elements being at opposite corners. -prop_RectSquareGrid_distance_corner_to_corner ∷ RectSquareGrid → Property -prop_RectSquareGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - distance g a b ≡ r + c - 2 - where (r, c) = size g - ps = indices g - a = head ps - b = last ps - -prop_RectSquareGrid_neighbour_count_in_bounds ∷ - RectSquareGrid → Int → Property -prop_RectSquareGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 4 - where x = g `pointAt` i - -prop_RectSquareGrid_num_min_paths_correct ∷ - RectSquareGrid → Int → Int → Property -prop_RectSquareGrid_num_min_paths_correct g i j = nonNull g ==> - minPathCount g a b ≡ M.choose (deltaX+deltaY) deltaX - where a = g `pointAt` i - b = g `pointAt` j - deltaX = abs $ fst b - fst a - deltaY = abs $ snd b - snd a - -prop_RectSquareGrid_boundary_count_correct ∷ RectSquareGrid → Property -prop_RectSquareGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (cartesianBoundaryCount . size) g - -cartesianBoundaryCount ∷ (Eq a, Num a) ⇒ (a, a) → a -cartesianBoundaryCount (0,_) = 0 -cartesianBoundaryCount (_,0) = 0 -cartesianBoundaryCount (1,c) = c -cartesianBoundaryCount (r,1) = r -cartesianBoundaryCount (r,c) = 2*(r+c) - 4 - -prop_RectSquareGrid_boundary_tiles_have_fewer_neighbours ∷ RectSquareGrid → Property -prop_RectSquareGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (4>) . map (numNeighbours g) . boundary $ g - - --- --- Toroidal grids with square tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedTorSquareGrid ∷ Int → Gen TorSquareGrid -sizedTorSquareGrid n = do - r ← choose (0,n) - let c = n `div` (r+1) - return $ torSquareGrid r c - -instance Arbitrary TorSquareGrid where - arbitrary = sized sizedTorSquareGrid - -prop_TorSquareGrid_tile_count_correct ∷ TorSquareGrid → Property -prop_TorSquareGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else r*c - where (r, c) = size g - -prop_TorSquareGrid_distance_in_bounds ∷ TorSquareGrid → Int → Int → Property -prop_TorSquareGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ (r+c) `div` 2 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by torSquareGrid is ever changed, this property --- may need to be changed too. -prop_TorSquareGrid_distance_corner_to_corner ∷ TorSquareGrid → Property -prop_TorSquareGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - distance g a b ≡ f - where (r, c) = size g - ps = indices g - a = head ps - b = last ps - f | r ≡ 1 && c ≡ 1 = 0 -- single-tile torus - | r ≡ 1 || c ≡ 1 = 1 -- a and b are the same - | otherwise = 2 - -prop_TorSquareGrid_neighbour_count_in_bounds ∷ TorSquareGrid → Int → Property -prop_TorSquareGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 4 - where x = g `pointAt` i - --- --- Circular hexagonal grids --- - --- We want the number of tiles in a test grid to be O(n) -sizedHexHexGrid ∷ Int → Gen HexHexGrid -sizedHexHexGrid n = return $ hexHexGrid s - where s = isqrt (n `div` 3) - -instance Arbitrary HexHexGrid where - arbitrary = sized sizedHexHexGrid - -prop_HexHexGrid_tile_count_correct ∷ HexHexGrid → Property -prop_HexHexGrid_tile_count_correct g = property $ - (length . indices) g ≡ if s ≤ 0 then 0 else 3*s*(s-1) + 1 - where s = size g - -prop_HexHexGrid_distance_in_bounds ∷ HexHexGrid → Int → Int → Property -prop_HexHexGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b < 2*s - where s = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by hexHexGrid is ever changed, this property --- may need to be changed too. It relies on the first and last elements being --- on opposite edges. -prop_HexHexGrid_distance_edge_to_edge ∷ HexHexGrid → Property -prop_HexHexGrid_distance_edge_to_edge g = s > 0 ==> distance g a b ≡ 2*s - 2 - where ps = indices g - a = head ps - b = last ps - s = size g - -prop_HexHexGrid_neighbour_count_in_bounds ∷ HexHexGrid → Int → Property -prop_HexHexGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 6 - where x = g `pointAt` i - -prop_HexHexGrid_boundary_count_correct ∷ HexHexGrid → Property -prop_HexHexGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (f . size) g - where f 0 = 0 - f 1 = 1 - f s = 6*(s-1) - -prop_HexHexGrid_boundary_tiles_have_fewer_neighbours ∷ HexHexGrid → Property -prop_HexHexGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (5>) . map (numNeighbours g) . boundary $ g - - --- --- Parallelogrammatical hexagonal grids --- - --- We want the number of tiles in a test grid to be O(n) -sizedParaHexGrid ∷ Int → Gen ParaHexGrid -sizedParaHexGrid n = do - r ← choose (0,n) - let c = n `div` (r+1) - return $ paraHexGrid r c - -instance Arbitrary ParaHexGrid where - arbitrary = sized sizedParaHexGrid - -prop_ParaHexGrid_tile_count_correct ∷ ParaHexGrid → Property -prop_ParaHexGrid_tile_count_correct g = property $ - tileCount g ≡ r*c - where (r, c) = size g - -prop_ParaHexGrid_distance_in_bounds ∷ ParaHexGrid → Int → Int → Property -prop_ParaHexGrid_distance_in_bounds g i j = nonNull g ==> - property $ distance g a b ≤ r+c-2 - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by paraHexGrid is ever changed, this property --- may need to be changed too. It relies on the first and last elements being --- at opposite corners on the longer diagonal. -prop_ParaHexGrid_distance_corner_to_corner ∷ ParaHexGrid → Property -prop_ParaHexGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - distance g a b ≡ r+c-2 - where ps = indices g - a = head ps - b = last ps - (r, c) = size g - -prop_ParaHexGrid_neighbour_count_in_bounds ∷ ParaHexGrid → Int → Property -prop_ParaHexGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 6 - where x = g `pointAt` i - -prop_ParaHexGrid_boundary_count_correct ∷ ParaHexGrid → Property -prop_ParaHexGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (cartesianBoundaryCount . size) g - -prop_ParaHexGrid_boundary_tiles_have_fewer_neighbours ∷ HexHexGrid → Property -prop_ParaHexGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (5>) . map (numNeighbours g) . boundary $ g - --- --- Rectangular grids with octagonal tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedRectOctGrid ∷ Int → Gen RectOctGrid -sizedRectOctGrid n = do - let n' = min n 12 -- calculation time for these grids grows quickly! - r ← choose (0,n') - let c = n' `div` (r+1) - return $ rectOctGrid r c - -instance Arbitrary RectOctGrid where - arbitrary = sized sizedRectOctGrid - -prop_RectOctGrid_tile_count_correct ∷ RectOctGrid → Property -prop_RectOctGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else r*c - where (r, c) = size g - -prop_RectOctGrid_distance_in_bounds ∷ RectOctGrid → Int → Int → Property -prop_RectOctGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ max r c - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by rectOctGrid is ever changed, this --- property may need to be changed too. It relies on the first and last --- elements being at opposite corners. -prop_RectOctGrid_distance_corner_to_corner ∷ RectOctGrid → Property -prop_RectOctGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - a ≡ b || distance g a b ≡ (max r c) - 1 - where (r, c) = size g - ps = indices g - a = head ps - b = last ps - -prop_RectOctGrid_neighbour_count_in_bounds ∷ - RectOctGrid → Int → Property -prop_RectOctGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 8 - where x = g `pointAt` i - -prop_RectOctGrid_num_min_paths_correct ∷ - RectOctGrid → Int → Int → Property -prop_RectOctGrid_num_min_paths_correct g i j = nonNull g ==> - minPathCount g a b ≡ - if a ≡ b then 1 else minPathCount2 g att b - where a = g `pointAt` i - b = g `pointAt` j - att = adjacentTilesToward g a b - -prop_RectOctGrid_boundary_count_correct ∷ RectOctGrid → Property -prop_RectOctGrid_boundary_count_correct g = property $ - (length . boundary) g ≡ (cartesianBoundaryCount . size) g - -prop_RectOctGrid_boundary_tiles_have_fewer_neighbours ∷ RectOctGrid → Property -prop_RectOctGrid_boundary_tiles_have_fewer_neighbours g = property $ - all (6>) . map (numNeighbours g) . boundary $ g - - --- --- Toroidal grids with octagonal tiles --- - --- We want the number of tiles in a test grid to be O(n) -sizedTorOctGrid ∷ Int → Gen TorOctGrid -sizedTorOctGrid n = do - r ← choose (0,n) - let c = n `div` (r+1) - return $ torOctGrid r c - -instance Arbitrary TorOctGrid where - arbitrary = sized sizedTorOctGrid - -prop_TorOctGrid_tile_count_correct ∷ TorOctGrid → Property -prop_TorOctGrid_tile_count_correct g = property $ - tileCount g ≡ if r ≤ 0 || c ≤ 0 then 0 else r*c - where (r, c) = size g - -prop_TorOctGrid_distance_in_bounds ∷ TorOctGrid → Int → Int → Property -prop_TorOctGrid_distance_in_bounds g i j = nonNull g ==> - distance g a b ≤ min r c + abs (r-c) - where (r, c) = size g - a = g `pointAt` i - b = g `pointAt` j - --- If the ordering produced by torOctGrid is ever changed, this property --- may need to be changed too. -prop_TorOctGrid_distance_corner_to_corner ∷ TorOctGrid → Property -prop_TorOctGrid_distance_corner_to_corner g = r > 0 && c > 0 ==> - distance g a b ≡ if tileCount g ≡ 1 then 0 else 1 - where (r, c) = size g - ps = indices g - a = head ps - b = last ps - -prop_TorOctGrid_neighbour_count_in_bounds ∷ TorOctGrid → Int → Property -prop_TorOctGrid_neighbour_count_in_bounds g i = nonNull g ==> - neighbourCount g x ≤ 8 - where x = g `pointAt` i - - -test ∷ Test -test = testGroup "Math.Geometry.GridQC" - [ - -- TriTriGrid tests - testProperty "prop_TriTriGrid_tile_count_correct" - prop_TriTriGrid_tile_count_correct, - testProperty "prop_distance_reflexive - TriTriGrid" - (prop_distance_reflexive ∷ TriTriGrid → Int → Property), - testProperty "prop_distance_symmetric - TriTriGrid" - (prop_distance_symmetric ∷ TriTriGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - TriTriGrid" - (prop_minDistance_cw_distance ∷ TriTriGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - TriTriGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ TriTriGrid → Property), - testProperty "prop_boundary_in_grid - TriTriGrid" - (prop_boundary_in_grid ∷ TriTriGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - TriTriGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ TriTriGrid → Int → Property), - testProperty "prop_TriTriGrid_boundary_count_correct" - prop_TriTriGrid_boundary_count_correct, - testProperty "prop_TriTriGrid_boundary_tiles_have_fewer_neighbours" - prop_TriTriGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - TriTriGrid" - (prop_centres_equidistant_from_boundary ∷ TriTriGrid → Property), - testProperty "prop_centres_farthest_from_boundary - TriTriGrid" - (prop_centres_farthest_from_boundary ∷ TriTriGrid → Int → Property), - testProperty "prop_TriTriGrid_distance_in_bounds" - prop_TriTriGrid_distance_in_bounds, - testProperty "prop_TriTriGrid_distance_edge_to_edge" - prop_TriTriGrid_distance_edge_to_edge, - testProperty "prop_TriTriGrid_neighbour_count_in_bounds" - prop_TriTriGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - TriTriGrid" - (prop_neighbours_cw_viewpoint ∷ TriTriGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - TriTriGrid" - (prop_edges_cw_neighbours ∷ TriTriGrid → Int → Property), - testProperty "prop_edges_are_adjacent - TriTriGrid" - (prop_edges_are_adjacent ∷ TriTriGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - TriTriGrid" - (prop_adjacentTilesToward_moves_closer ∷ - TriTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - TriTriGrid" - (prop_minimal_paths_have_min_length ∷ - TriTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - TriTriGrid" - (prop_minimal_paths_are_valid ∷ TriTriGrid → Int → Int → Property), - - -- ParaTriGrid tests - testProperty "prop_ParaTriGrid_tile_count_correct" - prop_ParaTriGrid_tile_count_correct, - testProperty "prop_distance_reflexive - ParaTriGrid" - (prop_distance_reflexive ∷ ParaTriGrid → Int → Property), - testProperty "prop_distance_symmetric - ParaTriGrid" - (prop_distance_symmetric ∷ ParaTriGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - ParaTriGrid" - (prop_minDistance_cw_distance ∷ ParaTriGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - ParaTriGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ ParaTriGrid → Property), - testProperty "prop_boundary_in_grid - ParaTriGrid" - (prop_boundary_in_grid ∷ ParaTriGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - ParaTriGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ ParaTriGrid → Int → Property), - testProperty "prop_ParaTriGrid_boundary_count_correct" - prop_ParaTriGrid_boundary_count_correct, - testProperty "prop_ParaTriGrid_boundary_tiles_have_fewer_neighbours" - prop_ParaTriGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - ParaTriGrid" - (prop_centres_equidistant_from_boundary ∷ ParaTriGrid → Property), - testProperty "prop_centres_farthest_from_boundary - ParaTriGrid" - (prop_centres_farthest_from_boundary ∷ ParaTriGrid → Int → Property), - testProperty "prop_ParaTriGrid_distance_in_bounds" - prop_ParaTriGrid_distance_in_bounds, - testProperty "prop_ParaTriGrid_distance_corner_to_corner" - prop_ParaTriGrid_distance_corner_to_corner, - testProperty "prop_ParaTriGrid_neighbour_count_in_bounds" - prop_ParaTriGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - ParaTriGrid" - (prop_neighbours_cw_viewpoint ∷ ParaTriGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - ParaTriGrid" - (prop_edges_cw_neighbours ∷ ParaTriGrid → Int → Property), - testProperty "prop_edges_are_adjacent - ParaTriGrid" - (prop_edges_are_adjacent ∷ ParaTriGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - ParaTriGrid" - (prop_adjacentTilesToward_moves_closer ∷ - ParaTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - ParaTriGrid" - (prop_minimal_paths_have_min_length ∷ - ParaTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - ParaTriGrid" - (prop_minimal_paths_are_valid ∷ ParaTriGrid → Int → Int → Property), - - -- RectTriGrid tests - testProperty "prop_RectTriGrid_tile_count_correct" - prop_RectTriGrid_tile_count_correct, - testProperty "prop_distance_reflexive - RectTriGrid" - (prop_distance_reflexive ∷ RectTriGrid → Int → Property), - testProperty "prop_distance_symmetric - RectTriGrid" - (prop_distance_symmetric ∷ RectTriGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - RectTriGrid" - (prop_minDistance_cw_distance ∷ RectTriGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - RectTriGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ RectTriGrid → Property), - testProperty "prop_boundary_in_grid - RectTriGrid" - (prop_boundary_in_grid ∷ RectTriGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - RectTriGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ RectTriGrid → Int → Property), - testProperty "prop_RectTriGrid_boundary_count_correct" - prop_RectTriGrid_boundary_count_correct, - testProperty "prop_RectTriGrid_boundary_tiles_have_fewer_neighbours" - prop_RectTriGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - RectTriGrid" - (prop_centres_equidistant_from_boundary ∷ RectTriGrid → Property), - testProperty "prop_centres_farthest_from_boundary - RectTriGrid" - (prop_centres_farthest_from_boundary ∷ RectTriGrid → Int → Property), - testProperty "prop_RectTriGrid_distance_in_bounds" - prop_RectTriGrid_distance_in_bounds, - testProperty "prop_RectTriGrid_neighbour_count_in_bounds" - prop_RectTriGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - RectTriGrid" - (prop_neighbours_cw_viewpoint ∷ RectTriGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - RectTriGrid" - (prop_edges_cw_neighbours ∷ RectTriGrid → Int → Property), - testProperty "prop_edges_are_adjacent - RectTriGrid" - (prop_edges_are_adjacent ∷ RectTriGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - RectTriGrid" - (prop_adjacentTilesToward_moves_closer ∷ - RectTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - RectTriGrid" - (prop_minimal_paths_have_min_length ∷ - RectTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - RectTriGrid" - (prop_minimal_paths_are_valid ∷ RectTriGrid → Int → Int → Property), - - -- TorTriGrid tests - testProperty "prop_TorTriGrid_tile_count_correct" - prop_TorTriGrid_tile_count_correct, - testProperty "prop_distance_reflexive - TorTriGrid" - (prop_distance_reflexive ∷ TorTriGrid → Int → Property), - testProperty "prop_distance_symmetric - TorTriGrid" - (prop_distance_symmetric ∷ TorTriGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - TorTriGrid" - (prop_minDistance_cw_distance ∷ TorTriGrid → Int → [Int] → Property), - testProperty "prop_TorTriGrid_distance_in_bounds" - prop_TorTriGrid_distance_in_bounds, - testProperty "prop_TorTriGrid_neighbour_count_in_bounds" - prop_TorTriGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - TorTriGrid" - (prop_neighbours_cw_viewpoint ∷ TorTriGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - TorTriGrid" - (prop_edges_cw_neighbours ∷ TorTriGrid → Int → Property), - testProperty "prop_edges_are_adjacent - TorTriGrid" - (prop_edges_are_adjacent ∷ TorTriGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - TorTriGrid" - (prop_adjacentTilesToward_moves_closer ∷ - TorTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - TorTriGrid" - (prop_minimal_paths_have_min_length ∷ - TorTriGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - TorTriGrid" - (prop_minimal_paths_are_valid ∷ TorTriGrid → Int → Int → Property), - - -- RectSquareGrid tests - testProperty "prop_RectSquareGrid_tile_count_correct" - prop_RectSquareGrid_tile_count_correct, - testProperty "prop_distance_reflexive - RectSquareGrid" - (prop_distance_reflexive ∷ RectSquareGrid → Int → Property), - testProperty "prop_distance_symmetric - RectSquareGrid" - (prop_distance_symmetric ∷ RectSquareGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - RectSquareGrid" - (prop_minDistance_cw_distance ∷ RectSquareGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - RectSquareGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ RectSquareGrid → Property), - testProperty "prop_boundary_in_grid - RectSquareGrid" - (prop_boundary_in_grid ∷ RectSquareGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - RectSquareGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ RectSquareGrid → Int → Property), - testProperty "prop_RectSquareGrid_boundary_count_correct" - prop_RectSquareGrid_boundary_count_correct, - testProperty "prop_RectSquareGrid_boundary_tiles_have_fewer_neighbours" - prop_RectSquareGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - RectSquareGrid" - (prop_centres_equidistant_from_boundary ∷ RectSquareGrid → Property), - testProperty "prop_centres_farthest_from_boundary - RectSquareGrid" - (prop_centres_farthest_from_boundary ∷ RectSquareGrid → Int → Property), - testProperty "prop_RectSquareGrid_distance_in_bounds" - prop_RectSquareGrid_distance_in_bounds, - testProperty "prop_RectSquareGrid_distance_corner_to_corner" - prop_RectSquareGrid_distance_corner_to_corner, - testProperty "prop_RectSquareGrid_neighbour_count_in_bounds" - prop_RectSquareGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - RectSquareGrid" - (prop_neighbours_cw_viewpoint ∷ RectSquareGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - RectSquareGrid" - (prop_edges_cw_neighbours ∷ RectSquareGrid → Int → Property), - testProperty "prop_edges_are_adjacent - RectSquareGrid" - (prop_edges_are_adjacent ∷ RectSquareGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - RectSquareGrid" - (prop_adjacentTilesToward_moves_closer ∷ - RectSquareGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - RectSquareGrid" - (prop_minimal_paths_have_min_length ∷ - RectSquareGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - RectSquareGrid" - (prop_minimal_paths_are_valid ∷ RectSquareGrid → Int → Int → Property), - testProperty "prop_RectSquareGrid_num_min_paths_correct" - prop_RectSquareGrid_num_min_paths_correct, - - -- TorSquareGrid tests - testProperty "prop_TorSquareGrid_tile_count_correct" - prop_TorSquareGrid_tile_count_correct, - testProperty "prop_distance_reflexive - TorSquareGrid" - (prop_distance_reflexive ∷ TorSquareGrid → Int → Property), - testProperty "prop_distance_symmetric - TorSquareGrid" - (prop_distance_symmetric ∷ TorSquareGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - TorSquareGrid" - (prop_minDistance_cw_distance ∷ TorSquareGrid → Int → [Int] → Property), - testProperty "prop_TorSquareGrid_distance_in_bounds" - prop_TorSquareGrid_distance_in_bounds, - testProperty "prop_TorSquareGrid_distance_corner_to_corner" - prop_TorSquareGrid_distance_corner_to_corner, - testProperty "prop_TorSquareGrid_neighbour_count_in_bounds" - prop_TorSquareGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - TorSquareGrid" - (prop_neighbours_cw_viewpoint ∷ TorSquareGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - TorSquareGrid" - (prop_edges_cw_neighbours ∷ TorSquareGrid → Int → Property), - testProperty "prop_edges_are_adjacent - TorSquareGrid" - (prop_edges_are_adjacent ∷ TorSquareGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - TorSquareGrid" - (prop_adjacentTilesToward_moves_closer ∷ - TorSquareGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - TorSquareGrid" - (prop_minimal_paths_have_min_length ∷ - TorSquareGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - TorSquareGrid" - (prop_minimal_paths_are_valid ∷ TorSquareGrid → Int → Int → Property), - - -- HexHexGrid tests - testProperty "prop_HexHexGrid_tile_count_correct" - prop_HexHexGrid_tile_count_correct, - testProperty "prop_distance_reflexive - HexHexGrid" - (prop_distance_reflexive ∷ HexHexGrid → Int → Property), - testProperty "prop_distance_symmetric - HexHexGrid" - (prop_distance_symmetric ∷ HexHexGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - HexHexGrid" - (prop_minDistance_cw_distance ∷ HexHexGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - HexHexGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ HexHexGrid → Property), - testProperty "prop_boundary_in_grid - HexHexGrid" - (prop_boundary_in_grid ∷ HexHexGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - HexHexGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ HexHexGrid → Int → Property), - testProperty "prop_HexHexGrid_boundary_count_correct" - prop_HexHexGrid_boundary_count_correct, - testProperty "prop_HexHexGrid_boundary_tiles_have_fewer_neighbours" - prop_HexHexGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - HexHexGrid" - (prop_centres_equidistant_from_boundary ∷ HexHexGrid → Property), - testProperty "prop_centres_farthest_from_boundary - HexHexGrid" - (prop_centres_farthest_from_boundary ∷ HexHexGrid → Int → Property), - testProperty "prop_HexHexGrid_distance_in_bounds" - prop_HexHexGrid_distance_in_bounds, - testProperty "prop_HexHexGrid_distance_edge_to_edge" - prop_HexHexGrid_distance_edge_to_edge, - testProperty "prop_HexHexGrid_neighbour_count_in_bounds" - prop_HexHexGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - HexHexGrid" - (prop_neighbours_cw_viewpoint ∷ HexHexGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - HexHexGrid" - (prop_edges_cw_neighbours ∷ HexHexGrid → Int → Property), - testProperty "prop_edges_are_adjacent - HexHexGrid" - (prop_edges_are_adjacent ∷ HexHexGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - HexHexGrid" - (prop_adjacentTilesToward_moves_closer ∷ - HexHexGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - HexHexGrid" - (prop_minimal_paths_have_min_length ∷ - HexHexGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - HexHexGrid" - (prop_minimal_paths_are_valid ∷ HexHexGrid → Int → Int → Property), - - -- ParaHexGrid tests - testProperty "prop_ParaHexGrid_tile_count_correct" - prop_ParaHexGrid_tile_count_correct, - testProperty "prop_distance_reflexive - ParaHexGrid" - (prop_distance_reflexive ∷ ParaHexGrid → Int → Property), - testProperty "prop_distance_symmetric - ParaHexGrid" - (prop_distance_symmetric ∷ ParaHexGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - ParaHexGrid" - (prop_minDistance_cw_distance ∷ ParaHexGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - ParaHexGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ ParaHexGrid → Property), - testProperty "prop_boundary_in_grid - ParaHexGrid" - (prop_boundary_in_grid ∷ ParaHexGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - TriTriGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ TriTriGrid → Int → Property), - testProperty "prop_ParaHexGrid_boundary_count_correct" - prop_ParaHexGrid_boundary_count_correct, - testProperty "prop_ParaHexGrid_boundary_tiles_have_fewer_neighbours" - prop_ParaHexGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - ParaHexGrid" - (prop_centres_equidistant_from_boundary ∷ ParaHexGrid → Property), - testProperty "prop_centres_farthest_from_boundary - ParaHexGrid" - (prop_centres_farthest_from_boundary ∷ ParaHexGrid → Int → Property), - testProperty "prop_ParaHexGrid_distance_in_bounds" - prop_ParaHexGrid_distance_in_bounds, - testProperty "prop_ParaHexGrid_distance_corner_to_corner" - prop_ParaHexGrid_distance_corner_to_corner, - testProperty "prop_ParaHexGrid_neighbour_count_in_bounds" - prop_ParaHexGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - ParaHexGrid" - (prop_neighbours_cw_viewpoint ∷ ParaHexGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - ParaHexGrid" - (prop_edges_cw_neighbours ∷ ParaHexGrid → Int → Property), - testProperty "prop_adjacentTilesToward_moves_closer - ParaHexGrid" - (prop_adjacentTilesToward_moves_closer ∷ - ParaHexGrid → Int → Int → Property), - testProperty "prop_edges_are_adjacent - ParaHexGrid" - (prop_edges_are_adjacent ∷ ParaHexGrid → Property), - testProperty "prop_minimal_paths_have_min_length - ParaHexGrid" - (prop_minimal_paths_have_min_length ∷ - ParaHexGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - ParaHexGrid" - (prop_minimal_paths_are_valid ∷ ParaHexGrid → Int → Int → Property), - - -- RectOctGrid tests - testProperty "prop_RectOctGrid_tile_count_correct" - prop_RectOctGrid_tile_count_correct, - testProperty "prop_distance_reflexive - RectOctGrid" - (prop_distance_reflexive ∷ RectOctGrid → Int → Property), - testProperty "prop_distance_symmetric - RectOctGrid" - (prop_distance_symmetric ∷ RectOctGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - RectOctGrid" - (prop_minDistance_cw_distance ∷ RectOctGrid → Int → [Int] → Property), - testProperty "prop_grid_and_boundary_are_both_null_or_not - RectOctGrid" - (prop_grid_and_boundary_are_both_null_or_not ∷ RectOctGrid → Property), - testProperty "prop_boundary_in_grid - RectOctGrid" - (prop_boundary_in_grid ∷ RectOctGrid → Property), - testProperty "prop_boundary_tiles_have_fewer_neighbours - RectOctGrid" - (prop_boundary_tiles_have_fewer_neighbours ∷ RectOctGrid → Int → Property), - testProperty "prop_RectOctGrid_boundary_count_correct" - prop_RectOctGrid_boundary_count_correct, - testProperty "prop_RectOctGrid_boundary_tiles_have_fewer_neighbours" - prop_RectOctGrid_boundary_tiles_have_fewer_neighbours, - testProperty "prop_centres_equidistant_from_boundary - RectOctGrid" - (prop_centres_equidistant_from_boundary ∷ RectOctGrid → Property), - testProperty "prop_centres_farthest_from_boundary - RectOctGrid" - (prop_centres_farthest_from_boundary ∷ RectOctGrid → Int → Property), - testProperty "prop_RectOctGrid_distance_in_bounds" - prop_RectOctGrid_distance_in_bounds, - testProperty "prop_RectOctGrid_distance_corner_to_corner" - prop_RectOctGrid_distance_corner_to_corner, - testProperty "prop_RectOctGrid_neighbour_count_in_bounds" - prop_RectOctGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - RectOctGrid" - (prop_neighbours_cw_viewpoint ∷ RectOctGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - RectOctGrid" - (prop_edges_cw_neighbours ∷ RectOctGrid → Int → Property), - testProperty "prop_edges_are_adjacent - RectOctGrid" - (prop_edges_are_adjacent ∷ RectOctGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - RectOctGrid" - (prop_adjacentTilesToward_moves_closer ∷ - RectOctGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - RectOctGrid" - (prop_minimal_paths_have_min_length ∷ - RectOctGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - RectOctGrid" - (prop_minimal_paths_are_valid ∷ RectOctGrid → Int → Int → Property), - testProperty "prop_RectOctGrid_num_min_paths_correct" - prop_RectOctGrid_num_min_paths_correct, - - -- TorOctGrid tests - testProperty "prop_TorOctGrid_tile_count_correct" - prop_TorOctGrid_tile_count_correct, - testProperty "prop_distance_reflexive - TorOctGrid" - (prop_distance_reflexive ∷ TorOctGrid → Int → Property), - testProperty "prop_distance_symmetric - TorOctGrid" - (prop_distance_symmetric ∷ TorOctGrid → Int → Int → Property), - testProperty "prop_minDistance_cw_distance - TorOctGrid" - (prop_minDistance_cw_distance ∷ TorOctGrid → Int → [Int] → Property), - testProperty "prop_TorOctGrid_distance_in_bounds" - prop_TorOctGrid_distance_in_bounds, - testProperty "prop_TorOctGrid_distance_corner_to_corner" - prop_TorOctGrid_distance_corner_to_corner, - testProperty "prop_TorOctGrid_neighbour_count_in_bounds" - prop_TorOctGrid_neighbour_count_in_bounds, - testProperty "prop_neighbours_cw_viewpoint - TorOctGrid" - (prop_neighbours_cw_viewpoint ∷ TorOctGrid → Int → Property), - testProperty "prop_edges_cw_neighbours - TorOctGrid" - (prop_edges_cw_neighbours ∷ TorOctGrid → Int → Property), - testProperty "prop_edges_are_adjacent - TorOctGrid" - (prop_edges_are_adjacent ∷ TorOctGrid → Property), - testProperty "prop_adjacentTilesToward_moves_closer - TorOctGrid" - (prop_adjacentTilesToward_moves_closer ∷ - TorOctGrid → Int → Int → Property), - testProperty "prop_minimal_paths_have_min_length - TorOctGrid" - (prop_minimal_paths_have_min_length ∷ - TorOctGrid → Int → Int → Property), - testProperty "prop_minimal_paths_are_valid - TorOctGrid" - (prop_minimal_paths_are_valid ∷ TorOctGrid → Int → Int → Property) - ] + TypeFamilies, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Math.Geometry.GridQC where + +import Math.Geometry.GridInternal + +import Prelude hiding (null) +import qualified Prelude as P (null) +import Data.Eq.Unicode ((≡), (≠)) +import Data.List (delete, nub, sort) +import Data.Ord.Unicode ((≤)) +import Test.Framework as TF (Test) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck + ((==>), Gen, Arbitrary, arbitrary, choose, Property, property, + vectorOf, elements) + +-- | @'isqrt' n@ returns the greatest integer not greater than the square root +-- of @n@. +isqrt ∷ Int → Int +isqrt n = (floor . sqrt) n' + where n' = fromIntegral n ∷ Float + +-- Given an arbitrary integer, select a corresponding point in the grid. +pointAt ∷ Grid g ⇒ g → Int → Index g +pointAt g i = indices g !! (i `mod` n) + where n = (length . indices) g + +minPathCount + ∷ (Eq (Index g), Grid g) ⇒ g → Index g → Index g → Int +minPathCount g a b = length . minimalPaths g a $ b + +minPathCount2 + ∷ (Eq (Index g), Grid g) ⇒ g → [Index g] → Index g → Int +minPathCount2 g as b = sum . map (\x → minPathCount g x b) $ as + +cartesianBoundaryCount ∷ (Eq a, Num a) ⇒ (a, a) → a +cartesianBoundaryCount (0,_) = 0 +cartesianBoundaryCount (_,0) = 0 +cartesianBoundaryCount (1,c) = c +cartesianBoundaryCount (r,1) = r +cartesianBoundaryCount (r,c) = 2*(r+c) - 4 + +involves ∷ Eq a ⇒ (a, a) → a → Bool +involves (a, b) c = c ≡ a || c ≡ b + +chooseIndices ∷ Grid g ⇒ g → Int → Gen [Index g] +chooseIndices g n = do + k ← choose (0,n) + if null g + then return [] + else vectorOf (k+2) (elements . indices $ g) + +chooseClosePointsUnbounded ∷ Gen ((Int, Int), (Int, Int)) +chooseClosePointsUnbounded = do + (x1,y1) ← arbitrary + x2 ← choose (x1-2,x1+2) + y2 ← choose (y1-2,y1+2) + return ((x1,y1), (x2,y2)) + +chooseClosePoints ∷ Grid g ⇒ g → Gen (Index g, Index g) +chooseClosePoints g = do + a ← elements . indices $ g + b ← elements . filter (\b → distance g a b < 6) . indices $ g + return (a, b) + +makeTests ∷ (Arbitrary t, Show t) ⇒ [(String, t → Property)] → [Test] +makeTests ts = map (\(s,t) → testProperty s t) ts + +-- +-- Tests that should apply to and are identical for all grids +-- + +class TestData t where + type BaseGrid t + grid ∷ t → BaseGrid t + points ∷ t → [Index (BaseGrid t)] + neighbourCountBounds ∷ t → (Int, Int) + twoClosePoints ∷ t → (Index (BaseGrid t),Index (BaseGrid t)) + +prop_indices_are_contained ∷ (TestData t, Grid (BaseGrid t), + Eq (Index (BaseGrid t))) ⇒ t → Property +prop_indices_are_contained t = nonNull g ==> g `contains` a + where g = grid t + (a:_) = points t + +prop_distance_reflexive ∷ (TestData t, Grid (BaseGrid t)) ⇒ t → Property +prop_distance_reflexive t = nonNull g ==> distance g a a ≡ 0 + where g = grid t + (a:_) = points t + +prop_distance_symmetric ∷ (TestData t, Grid (BaseGrid t)) ⇒ t → Property +prop_distance_symmetric t = + nonNull g ==> distance g a b ≡ distance g b a + where g = grid t + (a:b:_) = points t + +prop_custom_MinDistance_eq_default + ∷ (TestData t, Grid (BaseGrid t)) ⇒ t → Property +prop_custom_MinDistance_eq_default t = nonNull g ==> + minDistance g bs a ≡ defaultMinDistance g bs a + where g = grid t + (a:bs) = points t + +-- "cw" = "consistent with" + +prop_minDistance_cw_distance ∷ (TestData t, Grid (BaseGrid t)) ⇒ t → Property +prop_minDistance_cw_distance t = + nonNull g && (not . P.null) bs ==> + minDistance g (b:bs) a ≤ distance g b a + where g = grid t + (a:b:bs) = points t + +prop_neighbour_count_in_bounds + ∷ (TestData t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_neighbour_count_in_bounds t = nonNull g ==> + nMin ≤ n && n ≤ nMax + where g = grid t + (a:_) = points t + n = length . neighbours g $ a + (nMin, nMax) = neighbourCountBounds t + +prop_neighbours_are_adjacent + ∷ (TestData t, Grid (BaseGrid t)) + ⇒ t → Property +prop_neighbours_are_adjacent t = nonNull g ==> + and (map (isAdjacent g a) ns) + where g = grid t + (a:_) = points t + ns = neighbours g a + +prop_adjacentTilesToward_moves_closer + ∷ (TestData t, Grid (BaseGrid t), Eq (Index (BaseGrid t))) + ⇒ t → Property +prop_adjacentTilesToward_moves_closer t = nonNull g && a ≠ b ==> + and (map (< d) ns) + where g = grid t + (a:b:_) = points t + d = distance g a b + ns = nub $ map (\x → distance g x b) $ adjacentTilesToward g a b + +prop_minimal_paths_have_min_length + ∷ (TestData t, Grid (BaseGrid t), Eq (Index (BaseGrid t))) + ⇒ t → Property +prop_minimal_paths_have_min_length t = nonNull g ==> ns ≡ [d+1] + where g = grid t + (a,b) = twoClosePoints t + d = distance g a b + ns = nub . map length . minimalPaths g a $ b + +prop_minimal_paths_are_valid + ∷ (TestData t, Grid (BaseGrid t), Eq (Index (BaseGrid t))) + ⇒ t → Property +prop_minimal_paths_are_valid t = nonNull g ==> + and $ map (subsequentTilesInPathAreAdjacent g) $ minimalPaths g a b + where g = grid t + (a,b) = twoClosePoints t + +subsequentTilesInPathAreAdjacent + ∷ (Grid g, Eq (Index g)) ⇒ g → [Index g] → Bool +subsequentTilesInPathAreAdjacent _ [] = True +subsequentTilesInPathAreAdjacent g [x] = g `contains` x +subsequentTilesInPathAreAdjacent g (a:b:xs) = + isAdjacent g a b && subsequentTilesInPathAreAdjacent g (b:xs) + +prop_neighbour_cw_directionTo + ∷ (TestData t, Grid (BaseGrid t), Eq (Index (BaseGrid t)), + Eq (Direction (BaseGrid t))) + ⇒ t → Property +prop_neighbour_cw_directionTo t = nonNull g && a ≠ b ==> + (neighbour g a d) `elem` nextSteps + where g = grid t + (a,b) = twoClosePoints t + d = head . directionTo g a $ b + nextSteps = map (!!1) . minimalPaths g a $ b + +gridProperties + ∷ (TestData t, Grid (BaseGrid t), Arbitrary t, + Eq (Index (BaseGrid t)), Ord (Index (BaseGrid t)), + Eq (Direction (BaseGrid t))) + ⇒ String → [(String, t → Property)] +gridProperties s = + [ + ("prop_indices_are_contained: " ++ s, prop_indices_are_contained), + ("prop_distance_reflexive: " ++ s, prop_distance_reflexive), + ("prop_distance_symmetric: " ++ s, prop_distance_symmetric), + ("prop_custom_MinDistance_eq_default: " ++ s, prop_custom_MinDistance_eq_default), + ("prop_minDistance_cw_distance: " ++ s, prop_minDistance_cw_distance), + ("prop_neighbour_count_in_bounds: " ++ s, prop_neighbour_count_in_bounds), + ("prop_neighbours_are_adjacent: " ++ s, prop_neighbours_are_adjacent), + ("prop_adjacentTilesToward_moves_closer: " ++ s, prop_adjacentTilesToward_moves_closer), + ("prop_minimal_paths_have_min_length: " ++ s, prop_minimal_paths_have_min_length), + ("prop_minimal_paths_are_valid: " ++ s, prop_minimal_paths_are_valid), + ("prop_neighbour_cw_directionTo: " ++ s, prop_neighbour_cw_directionTo) + ] + +-- +-- Tests that should apply to and are identical for all finite grids +-- + +class TestDataF t where + expectedTileCount ∷ t → Int + maxDistance ∷ t → Int + +prop_tile_count_correct + ∷ (TestData t, TestDataF t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_tile_count_correct t = nonNull g ==> + tileCount g ≡ expectedTileCount t + where g = grid t + +prop_custom_tileCount_eq_default + ∷ (TestData t, Grid (BaseGrid t)) ⇒ t → Property +prop_custom_tileCount_eq_default t = nonNull g ==> + tileCount g ≡ defaultTileCount g + where g = grid t + +prop_distance_in_bounds + ∷ (TestData t, TestDataF t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_distance_in_bounds t = nonNull g ==> + 0 ≤ n && n ≤ maxDistance t + where g = grid t + (a:b:_) = points t + n = distance g a b + +prop_neighbours_cw_viewpoint + ∷ (TestData t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_neighbours_cw_viewpoint t = nonNull g ==> + sort (delete a (neighbours g a)) ≡ sort expected + where g = grid t + (a:_) = points t + expected = map fst $ filter (\p → 1 ≡ snd p) $ viewpoint g a +-- Note: In a small but unbounded grid, a tile can be its own neighbour. +-- However, when we calculate the distance between a tile and itself, we +-- get 0, not 1. That's why we have to delete the tile from its list +-- before comparing to the result from the neighbours function. + +prop_custom_edges_eq_default + ∷ (TestData t, Grid (BaseGrid t), Eq (Index (BaseGrid t)), + Ord (Index (BaseGrid t))) ⇒ t → Property +prop_custom_edges_eq_default t = nonNull g ==> + sort (edges g) ≡ sort (defaultEdges g) + where g = grid t + +prop_edges_cw_neighbours + ∷ (TestData t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_edges_cw_neighbours t = nonNull g ==> + sort (neighbours g a) ≡ sort expected + where g = grid t + (a:_) = points t + nEdges = filter (`involves` a) $ edges g + expected = map f nEdges + f (b,c) = if a ≡ b then c else b + +prop_edges_are_adjacent + ∷ (TestData t, Grid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_edges_are_adjacent t = property $ all f $ edges g + where g = grid t + f (a, b) = isAdjacent g a b + +finiteGridProperties + ∷ (TestData t, TestDataF t, Grid (BaseGrid t), Arbitrary t, + Eq (Index (BaseGrid t)), Ord (Index (BaseGrid t))) + ⇒ String → [(String, t → Property)] +finiteGridProperties s = + [ + ("prop_tile_count_correct: " ++ s, prop_tile_count_correct), + ("prop_custom_tileCount_eq_default: " ++ s, prop_custom_tileCount_eq_default), + ("prop_distance_in_bounds: " ++ s, prop_distance_in_bounds), + ("prop_neighbours_cw_viewpoint: " ++ s, prop_neighbours_cw_viewpoint), + ("prop_custom_edges_eq_default: " ++ s, prop_custom_edges_eq_default), + ("prop_edges_cw_neighbours: " ++ s, prop_edges_cw_neighbours), + ("prop_edges_are_adjacent: " ++ s, prop_edges_are_adjacent) + ] + +-- +-- Tests that should apply to and are identical for all bounded grids +-- + +class TestDataB t where + expectedBoundaryCount ∷ t → Int + +prop_boundary_count_correct + ∷ (TestData t, TestDataB t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_boundary_count_correct t = nonNull g ==> + (length . boundary) g ≡ expectedBoundaryCount t + where g = grid t + +prop_grid_and_boundary_are_both_null_or_not + ∷ (TestData t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_grid_and_boundary_are_both_null_or_not t = property $ + (P.null . boundary) g ≡ null g + where g = grid t + +prop_boundary_in_grid + ∷ (TestData t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_boundary_in_grid t = property $ + all (g `contains`) . boundary $ g + where g = grid t + +prop_boundary_tiles_have_fewer_neighbours + ∷ (TestData t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_boundary_tiles_have_fewer_neighbours t = nonNull g ==> + g `numNeighbours` b ≤ g `numNeighbours` a + where g = grid t + (a:_) = points t + (b:_) = boundary g + +prop_centres_equidistant_from_boundary + ∷ (TestData t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_centres_equidistant_from_boundary t = nonNull g ==> + (length . nub . map (minDistance g bs)) cs ≡ 1 + where g = grid t + bs = boundary g + cs = centre g + +prop_centres_farthest_from_boundary + ∷ (TestData t, BoundedGrid (BaseGrid t), Ord (Index (BaseGrid t))) + ⇒ t → Property +prop_centres_farthest_from_boundary t = + nonNull g && (not . isCentre g) a ==> + minDistance g bs a ≤ minDistance g bs c + where g = grid t + (a:_) = points t + (c:_) = centre g + bs = boundary g + +boundedGridProperties + ∷ (TestData t, TestDataB t, BoundedGrid (BaseGrid t), Arbitrary t, + Eq (Index (BaseGrid t)), Ord (Index (BaseGrid t))) + ⇒ String → [(String, t → Property)] +boundedGridProperties s = + [ + ("prop_boundary_count_correct: " ++ s, prop_boundary_count_correct), + ("prop_grid_and_boundary_are_both_null_or_not: " ++ s, prop_grid_and_boundary_are_both_null_or_not), + ("prop_boundary_in_grid: " ++ s, prop_boundary_in_grid), + ("prop_boundary_tiles_have_fewer_neighbours: " ++ s, prop_boundary_tiles_have_fewer_neighbours), + ("prop_centres_equidistant_from_boundary: " ++ s, prop_centres_equidistant_from_boundary), + ("prop_centres_farthest_from_boundary: " ++ s, prop_centres_farthest_from_boundary) + ]