grid-5.1: test/Math/Geometry/GridQC.hs

{-# LANGUAGE UnicodeSyntax, FlexibleContexts, ExistentialQuantification,
    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)
  ]