module Game.LambdaHack.Common.Kind
( Id, Speedup, Ops(..), COps(..), createOps, stdRuleset
) where
import Control.Exception.Assert.Sugar
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.Ix as Ix
import Data.List
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Data.Text as T
import Game.LambdaHack.Common.ContentDef
import Game.LambdaHack.Common.Frequency
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.TileKind
newtype Id c = Id Word8
deriving (Show, Eq, Ord, Ix.Ix, Enum, Bounded, Binary)
type family Speedup a
data Ops a = Ops
{ okind :: Id a -> a
, ouniqGroup :: GroupName -> Id a
, opick :: GroupName -> (a -> Bool) -> Rnd (Maybe (Id a))
, ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b
, ofoldrGroup :: forall b.
GroupName -> (Int -> Id a -> a -> b -> b) -> b -> b
, obounds :: !(Id a, Id a)
, ospeedup :: !(Maybe (Speedup a))
}
createOps :: forall a. Show a => ContentDef a -> Ops a
createOps ContentDef{getName, getFreq, content, validateSingle, validateAll} =
assert (length content <= fromEnum (maxBound :: Id a)) $
let kindMap :: EM.EnumMap (Id a) a
!kindMap = EM.fromDistinctAscList $ zip [Id 0..] content
kindFreq :: M.Map GroupName [(Int, (Id a, a))]
kindFreq =
let tuples = [ (cgroup, (n, (i, k)))
| (i, k) <- EM.assocs kindMap
, (cgroup, n) <- getFreq k, n > 0 ]
f m (cgroup, nik) = M.insertWith (++) cgroup [nik] m
in foldl' f M.empty tuples
okind i = fromMaybe (assert `failure` "no kind" `twith` (i, kindMap))
$ EM.lookup i kindMap
correct a = not (T.null (getName a)) && all ((> 0) . snd) (getFreq a)
singleOffenders = [ (offences, a)
| a <- content,
let offences = validateSingle a
, not (null offences) ]
allOffences = validateAll content
in assert (allB correct content) $
assert (null singleOffenders `blame` "some content items not valid"
`twith` singleOffenders) $
assert (null allOffences `blame` "the content set not valid"
`twith` (allOffences, content)) $
Ops
{ okind
, ouniqGroup = \cgroup ->
let freq = fromMaybe (assert `failure` "no unique group"
`twith` (cgroup, kindFreq))
$ M.lookup cgroup kindFreq
in case freq of
[(n, (i, _))] | n > 0 -> i
l -> assert `failure` "not unique" `twith` (l, cgroup, kindFreq)
, opick = \cgroup p ->
case M.lookup cgroup kindFreq of
Just freqRaw ->
let freq = toFreq ("opick ('" <> tshow cgroup <> "')") freqRaw
in if nullFreq freq
then return Nothing
else fmap Just $ frequency $ do
(i, k) <- freq
breturn (p k) i
_ -> return Nothing
, ofoldrWithKey = \f z -> foldr (\(i, a) -> f i a) z
$ EM.assocs kindMap
, ofoldrGroup = \cgroup f z ->
case M.lookup cgroup kindFreq of
Just freq -> foldr (\(p, (i, a)) -> f p i a) z freq
_ -> z
, obounds = ( fst $ EM.findMin kindMap
, fst $ EM.findMax kindMap )
, ospeedup = Nothing
}
data COps = COps
{ cocave :: !(Ops CaveKind)
, coitem :: !(Ops ItemKind)
, comode :: !(Ops ModeKind)
, coplace :: !(Ops PlaceKind)
, corule :: !(Ops RuleKind)
, cotile :: !(Ops TileKind)
}
stdRuleset :: Ops RuleKind -> RuleKind
stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"
instance Show COps where
show _ = "game content"
instance Eq COps where
(==) _ _ = True