module Game.LambdaHack.Common.Frequency
(
Frequency
, uniformFreq, toFreq
, scaleFreq, renameFreq, setFreq
, 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
data Frequency a = Frequency
{ runFrequency :: ![(Int, a)]
, nameFrequency :: Text
}
deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)
instance Monad Frequency where
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)
uniformFreq :: Text -> [a] -> Frequency a
uniformFreq name l = Frequency (map (\x -> (1, x)) l) name
toFreq :: Text -> [(Int, a)] -> Frequency a
toFreq = flip Frequency
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 f (_, y) | y == x = (n, x)
f my = my
in Frequency (map f xs) name
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