{-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-} -- | A list of items with relative frequencies of appearance. module Game.LambdaHack.Common.Frequency ( -- * The @Frequency@ type Frequency -- * Construction , uniformFreq, toFreq -- * Transformation , scaleFreq, renameFreq, setFreq -- * Consumption , nullFreq, runFrequency, nameFrequency , maxFreq, minFreq, meanFreq ) where import Control.Applicative import Control.Arrow (first, second) import Control.Exception.Assert.Sugar import Control.Monad import Data.Binary import Data.Foldable (Foldable) import Data.Hashable (Hashable) import Data.Ratio import Data.Text (Text) import Data.Traversable (Traversable) import GHC.Generics (Generic) import Game.LambdaHack.Common.Msg -- TODO: do not expose runFrequency -- | The frequency distribution type. Not normalized (operations may -- or may not group the same elements and sum their frequencies). -- -- The @Eq@ instance compares raw representations, not relative, -- normalized frequencies, so operations don't need to preserve -- the expected equalities, unless they do some kind of normalization -- (see 'Dice'). data Frequency a = Frequency { runFrequency :: ![(Int, a)] -- ^ give acces to raw frequency values , nameFrequency :: Text -- ^ short description for debug, etc.; -- keep it lazy, because it's rarely used } deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic) instance Monad Frequency where {-# INLINE return #-} return x = Frequency [(1, x)] "return" Frequency xs name >>= f = Frequency [ (p * q, y) | (p, x) <- xs , (q, y) <- runFrequency (f x) ] ("bind (" <> name <> ")") instance Functor Frequency where fmap f (Frequency xs name) = Frequency (map (second f) xs) name instance Applicative Frequency where pure = return Frequency fs fname <*> Frequency ys yname = Frequency [ (p * q, f y) | (p, f) <- fs , (q, y) <- ys ] ("(" <> fname <> ") <*> (" <> yname <> ")") instance MonadPlus Frequency where mplus (Frequency xs xname) (Frequency ys yname) = let name = case (xs, ys) of ([], []) -> "[]" ([], _ ) -> yname (_, []) -> xname _ -> "(" <> xname <> ") ++ (" <> yname <> ")" in Frequency (xs ++ ys) name mzero = Frequency [] "[]" instance Alternative Frequency where (<|>) = mplus empty = mzero instance Hashable a => Hashable (Frequency a) instance Binary a => Binary (Frequency a) -- | Uniform discrete frequency distribution. uniformFreq :: Text -> [a] -> Frequency a uniformFreq name l = Frequency (map (\x -> (1, x)) l) name -- | Takes a name and a list of frequencies and items -- into the frequency distribution. toFreq :: Text -> [(Int, a)] -> Frequency a toFreq = flip Frequency -- | Scale frequecy distribution, multiplying it -- by a positive integer constant. scaleFreq :: Show a => Int -> Frequency a -> Frequency a scaleFreq n (Frequency xs name) = assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) \$ Frequency (map (first (* n)) xs) name -- | Change the description of the frequency. renameFreq :: Text -> Frequency a -> Frequency a renameFreq newName fr = fr {nameFrequency = newName} -- | Set frequency of an element. setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a setFreq (Frequency xs name) x n = let f (_, y) | y == x = (n, x) f my = my in Frequency (map f xs) name -- | Test if the frequency distribution is empty. nullFreq :: Frequency a -> Bool nullFreq (Frequency fs _) = all (<= 0) \$ map fst fs maxFreq :: (Show a, Ord a) => Frequency a -> a maxFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of [] -> assert `failure` fr ys -> maximum \$ map snd ys minFreq :: (Show a, Ord a) => Frequency a -> a minFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of [] -> assert `failure` fr ys -> minimum \$ map snd ys meanFreq :: (Show a, Integral a) => Frequency a -> Rational meanFreq fr@(Frequency xs _) = case filter ((> 0 ) . fst) xs of [] -> assert `failure` fr ys -> let sumP = sum \$ map fst ys sumX = sum [ fromIntegral p * x | (p, x) <- ys ] in if sumX == 0 then 0 else fromIntegral sumX % fromIntegral sumP