module Game.LambdaHack.Common.Kind
( Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset
, Tab, createTab, accessTab
) where
import Control.Exception.Assert.Sugar
import qualified Data.Array.Unboxed as A
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 Data.Text (Text)
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.FactionKind
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)
data family Speedup a
data instance Speedup TileKind = TileSpeedup
{ isClearTab :: !Tab
, isLitTab :: !Tab
, isWalkableTab :: !Tab
, isPassableTab :: !Tab
, isDoorTab :: !Tab
, isSuspectTab :: !Tab
, isChangeableTab :: !Tab
}
newtype Tab = Tab (A.UArray (Id TileKind) Bool)
createTab :: Ops TileKind -> (TileKind -> Bool) -> Tab
createTab Ops{ofoldrWithKey, obounds} p =
let f _ k acc = p k : acc
clearAssocs = ofoldrWithKey f []
in Tab $ A.listArray obounds clearAssocs
accessTab :: Tab -> Id TileKind -> Bool
accessTab (Tab tab) ki = tab A.! ki
data Ops a = Ops
{ okind :: Id a -> a
, ouniqGroup :: Text -> Id a
, opick :: Text -> (a -> Bool) -> Rnd (Maybe (Id a))
, ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b
, ofoldrGroup :: forall b. Text -> (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, validate} =
assert (length content <= fromEnum (maxBound :: Id a)) $
let kindMap :: EM.EnumMap (Id a) a
!kindMap = EM.fromDistinctAscList $ zip [Id 0..] content
kindFreq :: M.Map Text [(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)
offenders = validate content
in assert (allB correct content) $
assert (null offenders `blame` "content not valid" `twith` offenders)
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 ('" <> 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)
, cofaction :: !(Ops FactionKind)
, 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