test/QuickCheck.hs

   1 {-# LANGUAGE FlexibleInstances #-}
   2 {-# LANGUAGE ScopedTypeVariables #-}
   3 {-# OPTIONS_GHC -fno-warn-orphans #-}
   4 module QuickCheck where
   5
   6 import Test.QuickCheck
   7 import Test.Tasty
   8 import Test.Tasty.QuickCheck
   9
  10 import Control.Arrow (first)
  11 import Control.Monad (replicateM)
  12 import Data.Hashable (Hashable)
  13 import qualified Data.Map.Strict as Map
  14 import Data.Ratio
  15 import GHC.Exts (IsList(..))
  16 import Prelude
  17 import System.Random (Random(..))
  18 import qualified Data.Set as Set
  19
  20 import Majority.Judgment
  21 import Types
  22
  23 quickchecks :: TestTree
  24 quickchecks =
  25         testGroup "QuickCheck"
  26          [ testProperty "arbitraryMerits" $ \(SameLength (Merit x::Merit G6,Merit y::Merit G6)) ->
  27                 Map.keys x == Map.keys y &&
  28                 sum x == sum y
  29          , testGroup "MajorityValue"
  30                  [ testProperty "compare" $ \(SameLength (x::MajorityValue G6,y)) ->
  31                         expandValue x`compare` expandValue y == x`compare`y
  32                  ]
  33          {-
  34          , testProperty "majorityGauge and majorityValue consistency" $
  35                  \(SameLength (x@(Merit xs)::Merit G6,y@(Merit ys))) ->
  36                         not (all (==0) xs || all (==0) ys) ==>
  37                         case majorityGauge x`compare`majorityGauge y of
  38                          LT -> majorityValue x < majorityValue y
  39                          GT -> majorityValue x > majorityValue y
  40                          EQ -> True
  41          -}
  42          ]
  43
  44 -- | Decompress a 'MajorityValue'.
  45 expandValue :: MajorityValue a -> [a]
  46 expandValue (MajorityValue ms) =
  47         let d = foldr lcm 1 (denominator . middleShare <$> ms) in
  48         go $ (\m -> (numerator (middleShare m) * d, lowGrade m, highGrade m)) <$> ms
  49         where
  50         go [] = []
  51         go ((s,l,h):xs) = concat (replicate (fromIntegral s) [l, h]) ++ go xs
  52
  53 -- | @arbitraryMerits n@ arbitrarily generates 'n' lists of 'Merit'
  54 -- for the same arbitrary grades,
  55 -- and with the same total 'Share' of individual judgments.
  56 arbitraryMerits :: forall g. (Bounded g, Enum g, Ord g) => Int -> Gen [Merit g]
  57 arbitraryMerits n = sized $ \shareSum -> do
  58         minG <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))
  59         maxG <- choose (minG, fromEnum(maxBound::g))
  60         let gs::[g] = toEnum minG`enumFromTo`toEnum maxG
  61         let lenGrades = maxG - minG + 1
  62         replicateM n $ do
  63                 shares  <- resize shareSum $ arbitrarySizedPositiveRationalSum lenGrades
  64                 shares' :: [Share] <- arbitraryPad (lenGrades - length shares) (return 0) shares
  65                 return $ Merit $ fromList $ zip gs shares'
  66
  67 -- | @arbitrarySizedNaturalSum maxLen@
  68 -- arbitrarily chooses a list of 'length' at most 'maxLen',
  69 -- containing 'Int's summing up to 'sized'.
  70 arbitrarySizedNaturalSum :: Int -> Gen [Int]
  71 arbitrarySizedNaturalSum maxLen = sized (go maxLen)
  72         where
  73         go :: Int -> Int -> Gen [Int]
  74         go len tot | len <= 0 = return []
  75                    | len == 1 = return [tot]
  76                    | tot <= 0 = return [tot]
  77         go len tot = do
  78                 d <- choose (0, tot)
  79                 (d:) <$> go (len-1) (tot - d)
  80
  81 -- | @arbitrarySizedPositiveRationalSum maxLen@
  82 -- arbitrarily chooses a list of 'length' at most 'maxLen',
  83 -- containing positive 'Rational's summing up to 'sized'.
  84 arbitrarySizedPositiveRationalSum :: Int -> Gen [Rational]
  85 arbitrarySizedPositiveRationalSum maxLen = sized (go maxLen . fromIntegral)
  86         where
  87         go :: Int -> Rational -> Gen [Rational]
  88         go len tot | len <= 0 = return []
  89                    | len == 1 = return [tot]
  90                    | tot <= 0 = return [tot]
  91         go len tot = do
  92                 d <- choose (0, tot)
  93                 (d:) <$> go (len-1) (tot - d)
  94
  95 instance Random Rational where
  96         randomR (minR, maxR) g =
  97                 if d - b == 0
  98                 then first (% b) $ randomR (a, c) g
  99                 else first (bd2ac . nat2bd) $ randomR (0, toInteger (maxBound::Int)) g
 100                 where
 101                 a = numerator   minR
 102                 b = denominator minR
 103                 c = numerator   maxR
 104                 d = denominator maxR
 105                 nat2bd x = ((d - b) % toInteger (maxBound::Int)) * (x%1) + (b%1)
 106                 bd2ac x = alpha * x + beta
 107                         where
 108                         alpha = (c-a) % (d-b)
 109                         beta = (a%1) - alpha * (b%1)
 110
 111         random = randomR (toInteger (minBound::Int)%1, toInteger (maxBound::Int)%1)
 112
 113 -- | @arbitraryPad n pad xs@
 114 -- arbitrarily grows list 'xs' with 'pad' elements
 115 -- up to length 'n'.
 116 arbitraryPad :: (Num i, Integral i) => i -> Gen a -> [a] -> Gen [a]
 117 arbitraryPad n pad [] = replicateM (fromIntegral n) pad
 118 arbitraryPad n pad xs = do
 119         (r, xs') <- go n xs
 120         if r > 0
 121          then arbitraryPad r pad xs'
 122          else return xs'
 123         where
 124         go r xs' | r <= 0 = return (0,xs')
 125         go r [] =  arbitrary >>= \b ->
 126                 if b then pad >>= \p -> ((p:)<$>) <$> go (r-1) []
 127                      else return (r,[])
 128         go r (x:xs') = arbitrary >>= \b ->
 129                 if b then pad >>= \p -> (([p,x]++)<$>) <$> go (r-1) xs'
 130                      else ((x:)<$>) <$> go r xs'
 131
 132 -- | Like 'nub', but O(n * log n).
 133 nubList :: Ord a => [a] -> [a]
 134 nubList = go Set.empty where
 135         go _ [] = []
 136         go s (x:xs) | x`Set.member`s = go s xs
 137                     | otherwise      = x:go (Set.insert x s) xs
 138
 139 instance Arbitrary G6 where
 140         arbitrary = arbitraryBoundedEnum
 141 instance (Arbitrary g, Bounded g, Enum g, Ord g, Show g) => Arbitrary (Merit g) where
 142         arbitrary = head <$> arbitraryMerits 1
 143         shrink (Merit m) = Merit <$> shrink m
 144 instance
 145  ( Arbitrary c, Bounded c, Enum c, Eq c, Hashable c, Show c
 146  , Arbitrary g, Bounded g, Enum g, Ord g, Show g
 147  ) => Arbitrary (MeritByChoice c g) where
 148         arbitrary = do
 149                 minP <- choose (fromEnum(minBound::c), fromEnum(maxBound::c))
 150                 maxP <- choose (minP, fromEnum(maxBound::c))
 151                 let ps = toEnum minP`enumFromTo`toEnum maxP
 152                 let ms = arbitraryMerits (maxP - minP + 1)
 153                 fromList . zip ps <$> ms
 154 instance (Bounded g, Eq g, Integral g, Arbitrary g) => Arbitrary (MajorityValue g) where
 155         arbitrary = head . (majorityValue <$>) <$> arbitraryMerits 1
 156         shrink (MajorityValue vs) = MajorityValue <$> shrink vs
 157 instance (Bounded g, Enum g) => Arbitrary (Middle g) where
 158         arbitrary = do
 159                 lowG  <- choose (fromEnum(minBound::g), fromEnum(maxBound::g))
 160                 highG <- choose (lowG, fromEnum(maxBound::g))
 161                 share <- choose (0, 1)
 162                 return $ Middle share (toEnum lowG) (toEnum highG)
 163
 164 -- * Type 'SameLength'
 165 newtype SameLength a = SameLength a
 166  deriving (Eq, Show)
 167 instance Functor SameLength where
 168         fmap f (SameLength x) = SameLength (f x)
 169 instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength (MajorityValue g, MajorityValue g)) where
 170         arbitrary = do
 171                 SameLength (x,y) <- arbitrary
 172                 return $ SameLength (MajorityValue x, MajorityValue y)
 173 instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength (Merit g, Merit g)) where
 174         arbitrary = do
 175                 vs <- arbitraryMerits 2
 176                 case vs of
 177                  [x,y] -> return $ SameLength (x,y)
 178                  _ -> undefined
 179 instance (Arbitrary g, Bounded g, Enum g, Ord g) => Arbitrary (SameLength ([Middle g], [Middle g])) where
 180         arbitrary = do
 181                 SameLength (m0, m1) <- arbitrary
 182                 return $ SameLength
 183                  ( unMajorityValue $ majorityValue m0
 184                  , unMajorityValue $ majorityValue m1 )