module Game.LambdaHack.Common.Kind
(
Id, sentinelId, Speedup(..), Ops(..), COps(..), createOps, stdRuleset
, Array, (!), (//), listArray, array, bounds, foldlArray
) where
import qualified Data.Array.Unboxed as A
import Data.Binary
import qualified Data.EnumMap.Strict as EM
import qualified Data.Ix as Ix
import qualified Data.List as L
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.Misc
import Game.LambdaHack.Common.Msg
import Game.LambdaHack.Common.Random
import Game.LambdaHack.Content.ActorKind
import Game.LambdaHack.Content.CaveKind
import Game.LambdaHack.Content.FactionKind
import Game.LambdaHack.Content.ItemKind
import Game.LambdaHack.Content.PlaceKind
import Game.LambdaHack.Content.RuleKind
import Game.LambdaHack.Content.StrategyKind
import Game.LambdaHack.Content.TileKind
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.Frequency
newtype Id c = Id Word8
deriving (Show, Eq, Ord, Ix.Ix, Enum)
instance Binary (Id c) where
put (Id i) = put i
get = fmap Id get
sentinelId :: Id c
sentinelId = Id 255
data family Speedup a
data instance Speedup TileKind = TileSpeedup
{ isClearTab :: Id TileKind -> Bool
, isLitTab :: Id TileKind -> Bool
}
data Ops a = Ops
{ osymbol :: Id a -> Char
, oname :: Id a -> Text
, okind :: Id a -> a
, ouniqGroup :: Text -> Id a
, opick :: Text -> (a -> Bool) -> Rnd (Id a)
, ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b
, obounds :: (Id a, Id a)
, ospeedup :: Speedup a
}
createOps :: forall a. Show a => ContentDef a -> Ops a
createOps ContentDef{getSymbol, getName, getFreq, content, validate} =
assert (Id (fromIntegral $ length content) < sentinelId) $
let kindAssocs :: [(Word8, a)]
kindAssocs = L.zip [0..] content
kindMap :: EM.EnumMap (Id a) a
kindMap = EM.fromDistinctAscList $ L.zip [Id 0..] content
kindFreq :: M.Map Text (Frequency (Id a, a))
kindFreq =
let tuples = [ (group, (n, (Id i, k)))
| (i, k) <- kindAssocs
, (group, n) <- getFreq k, n > 0 ]
f m (group, nik) = M.insertWith (++) group [nik] m
lists = L.foldl' f M.empty tuples
nameFreq group = toFreq $ "opick ('" <> group <> "')"
in M.mapWithKey nameFreq lists
okind i = fromMaybe (assert `failure` (i, kindMap))
$ EM.lookup i kindMap
correct a = not (T.null (getName a)) && L.all ((> 0) . snd) (getFreq a)
offenders = validate content
in assert (allB correct content) $
assert (L.null offenders `blame` ("content failed validation: " :: Text,
offenders))
Ops
{ osymbol = getSymbol . okind
, oname = getName . okind
, okind = okind
, ouniqGroup = \ group ->
let freq = fromMaybe (assert `failure` (group, kindFreq))
$ M.lookup group kindFreq
in case runFrequency freq of
[(n, (i, _))] | n > 0 -> i
l -> assert `failure` l
, opick = \ group p ->
let freq = fromMaybe (assert `failure` (group, kindFreq))
$ M.lookup group kindFreq
in frequency $ do
(i, k) <- freq
breturn (p k) i
, ofoldrWithKey = \ f z -> L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs
, obounds = ( fst $ EM.findMin kindMap
, fst $ EM.findMax kindMap )
, ospeedup = undefined
}
data COps = COps
{ coactor :: !(Ops ActorKind)
, cocave :: !(Ops CaveKind)
, cofact :: !(Ops FactionKind)
, coitem :: !(Ops ItemKind)
, coplace :: !(Ops PlaceKind)
, corule :: !(Ops RuleKind)
, costrat :: !(Ops StrategyKind)
, 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
newtype Array i c = Array (A.UArray i Word8)
deriving Eq
instance (Ix.Ix i, Binary i) => Binary (Array i c) where
put (Array a) = put a
get = fmap Array get
instance (Ix.Ix i, Show i) => Show (Array i c) where
show a = "Kind.Array with bounds " ++ show (bounds a)
(!) :: Ix.Ix i => Array i c -> i -> Id c
(!) (Array a) i = Id $ a A.! i
(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c
(//) (Array a) l = Array $ a A.// [(i, e) | (i, Id e) <- l]
listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c
listArray bds l = Array $ A.listArray bds [e | Id e <- l]
array :: Ix.Ix i => (i, i) -> [(i, Id c)] -> Array i c
array bds l = Array $ A.array bds [(i, e) | (i, Id e) <- l]
bounds :: Ix.Ix i => Array i c -> (i, i)
bounds (Array a) = A.bounds a
foldlArray :: Ix.Ix i => (a -> Id c -> a) -> a -> Array i c -> a
foldlArray f z0 (Array a) = lgo z0 $ A.elems a
where lgo z [] = z
lgo z (x : xs) = let fzx = f z (Id x) in fzx `seq` lgo fzx xs