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
{ nameFrequency :: Text
, runFrequency :: ![(Int, a)]
}
deriving (Show, Read, Eq, Ord, Foldable, Traversable, Generic)
instance Monad Frequency where
return x = Frequency "return" [(1, x)]
Frequency name xs >>= f =
Frequency ("bind (" <> name <> ")")
[ (p * q, y) | (p, x) <- xs
, (q, y) <- runFrequency (f x) ]
instance Functor Frequency where
fmap f (Frequency name xs) = Frequency name (map (second f) xs)
instance Applicative Frequency where
pure = return
Frequency fname fs <*> Frequency yname ys =
Frequency ("(" <> fname <> ") <*> (" <> yname <> ")")
[ (p * q, f y) | (p, f) <- fs
, (q, y) <- ys ]
instance MonadPlus Frequency where
mplus (Frequency xname xs) (Frequency yname ys) =
let name = case (xs, ys) of
([], []) -> "[]"
([], _ ) -> yname
(_, []) -> xname
_ -> "(" <> xname <> ") ++ (" <> yname <> ")"
in Frequency name (xs ++ ys)
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 = Frequency name . map (\x -> (1, x))
toFreq :: Text -> [(Int, a)] -> Frequency a
toFreq = Frequency
scaleFreq :: Show a => Int -> Frequency a -> Frequency a
scaleFreq n (Frequency name xs) =
assert (n > 0 `blame` "non-positive frequency scale" `twith` (name, n, xs)) $
Frequency name (map (first (* n)) xs)
renameFreq :: Text -> Frequency a -> Frequency a
renameFreq newName fr = fr {nameFrequency = newName}
setFreq :: Eq a => Frequency a -> a -> Int -> Frequency a
setFreq (Frequency name xs) x n =
let f (_, y) | y == x = (n, x)
f my = my
in Frequency name $ map f xs
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