NormaliseScores.hs

{-# LANGUAGE FlexibleInstances #-}
module NLTG.NormaliseScores where

import System.Random
import Test.QuickCheck

-- | Given a lower and upper bound and a set of scores
--   Stretch the scores so that at least one of the bounds is reached
--   @normalise (-10,10) [-3,5,4] == [-6,10,8]@
normalise :: (Ord a, Fractional a) => (a,a) -> [a] -> [a]
normalise (lo,hi) [] = [] -- thanks, QuickCheck!
normalise (lo,hi) xs =
  case () of
   _ | lo  >= hi -> error $ "lower bound must be less than upper bound"
                    -- thanks, QuickCheck!
     | myLo < lo -> error $ "minimum (" ++ show myLo ++ ") is less than lower bound (" ++ show lo ++")"
     | myHi > hi -> error $ "maximum (" ++ show myHi ++ ") is greater than upper bound (" ++ show hi ++")"
     | otherwise -> map (\x -> fromZero (scale * toZero x)) xs
 where
  myLo = minimum xs
  myHi = maximum xs
  midpoint = (lo + hi) / 2
  toZero   x = x - midpoint
  fromZero x = x + midpoint
  scale | myLo >= midpoint = hiScale -- thanks, QuickCheck!
        | myHi <= midpoint = loScale -- prop_normalise_bounds
        | otherwise        = min loScale hiScale
  hiScale = toZero hi / toZero myHi
  loScale = toZero lo / toZero myLo

-- ----------------------------------------------------------------------
-- testing
-- ----------------------------------------------------------------------

normaliseTs (TestScores bnds xs) = normalise bnds xs

prop_normalise_len ts =
  length xs == length (normalise (lo, hi) xs)
 where
  (TestScores (lo, hi) xs) = frac ts

prop_normalise_bounds :: TestScores Integer -> Bool
prop_normalise_bounds ts =
  all (>= lo) nxs && all (<= hi) nxs
 where
  nxs = normalise (lo, hi) xs
  (TestScores (lo, hi) xs) = frac ts

prop_normalise_stretch :: TestScores Integer -> Bool
prop_normalise_stretch ts =
  any (== lo) nxs || any (== hi) nxs || all (== midpoint) nxs
 where
  nxs = normalise (lo, hi) xs
  (TestScores (lo, hi) xs) = frac ts
  midpoint = lo + hi  / 2

frac :: TestScores Integer -> TestScores Rational
frac (TestScores (lo, hi) xs) =
 TestScores (fromIntegral lo, fromIntegral hi) (map fromIntegral xs)

data TestScores a = TestScores (a, a) [a]
 deriving Show

instance Arbitrary (TestScores Integer) where
  arbitrary   =
    do lo <- arbitrary
       hi <- arbitrary `suchThat` (> lo)
       xs <- listOf1 (choose (lo,hi))
       return $ TestScores (lo , hi) xs