{-# LANGUAGE DeriveFoldable, DeriveGeneric, DeriveTraversable #-}
module Game.LambdaHack.Common.Frequency
(
Frequency
, uniformFreq, toFreq
, scaleFreq, renameFreq, setFreq
, nullFreq, runFrequency, nameFrequency
, minFreq, maxFreq, mostFreq, meanFreq
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.Applicative
import Control.DeepSeq
import Data.Binary
import Data.Hashable (Hashable)
import Data.Ord (comparing)
import GHC.Generics (Generic)
data Frequency a = Frequency
{ runFrequency :: ![(Int, a)]
, nameFrequency :: Text
}
deriving (Show, 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)
instance NFData a => NFData (Frequency a)
uniformFreq :: Text -> [a] -> Frequency a
uniformFreq name l = Frequency (map (\x -> (1, x)) l) name
toFreq :: Text -> [(Int, a)] -> Frequency a
toFreq name l = Frequency (filter ((> 0 ) . fst) l) name
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
renameFreq :: Text -> Frequency a -> Frequency a
renameFreq newName fr = fr {nameFrequency = newName}
setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a
setFreq (Frequency xs name) x n =
let xsNew = [(n, x) | n <= 0] ++ filter ((/= x) . snd) xs
in Frequency xsNew name
nullFreq :: Frequency a -> Bool
nullFreq (Frequency fs _) = null fs
minFreq :: Ord a => Frequency a -> Maybe a
minFreq fr = if nullFreq fr then Nothing else Just $ minimum fr
maxFreq :: Ord a => Frequency a -> Maybe a
maxFreq fr = if nullFreq fr then Nothing else Just $ maximum fr
mostFreq :: Frequency a -> Maybe a
mostFreq fr = if nullFreq fr then Nothing
else Just $ snd $ maximumBy (comparing fst) $ runFrequency fr
meanFreq :: Frequency Int -> Int
meanFreq fr@(Frequency xs _) = case xs of
[] -> assert `failure` fr
_ -> let sumX = sum [ p * x | (p, x) <- xs ]
sumP = sum $ map fst xs
in sumX `divUp` sumP