module Game.LambdaHack.Kind
(
Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset
, Array, (!), (//), listArray, array, bounds, foldlArray
) where
import Data.Binary
import qualified Data.List as L
import qualified Data.IntMap as IM
import qualified Data.Map as M
import qualified Data.Word as Word
import qualified Data.Array.Unboxed as A
import qualified Data.Ix as Ix
import Game.LambdaHack.Utils.Assert
import Game.LambdaHack.Utils.Frequency
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.CDefs
import Game.LambdaHack.Random
import Game.LambdaHack.Misc
newtype Id c = Id Word8 deriving (Show, Eq, Ord, Ix.Ix)
instance Binary (Id c) where
put (Id i) = put i
get = fmap Id get
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 -> String
, okind :: Id a -> a
, ouniqGroup :: String -> Id a
, opick :: String -> (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 => CDefs a -> Ops a
createOps CDefs{getSymbol, getName, getFreq, content, validate} =
let kindAssocs :: [(Word.Word8, a)]
kindAssocs = L.zip [0..] content
kindMap :: IM.IntMap a
kindMap = IM.fromDistinctAscList $ L.zip [0..] content
kindFreq :: M.Map String (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 (Id i) = kindMap IM.! fromEnum i
correct a = not (L.null (getName a)) && L.all ((> 0) . snd) (getFreq a)
offenders = validate content
in assert (allB correct content) $
assert (L.null offenders `blame` ("content not validated:", offenders)) $
Ops
{ osymbol = getSymbol . okind
, oname = getName . okind
, okind = okind
, ouniqGroup = \ group ->
case runFrequency $ kindFreq M.! group of
[(n, (i, _))] | n > 0 -> i
l -> assert `failure` l
, opick = \ group p -> frequency $ do
(i, k) <- kindFreq M.! group
breturn (p k) i
, ofoldrWithKey = \ f z -> L.foldr (\ (i, a) -> f (Id i) a) z kindAssocs
, obounds =
let limits = let (i1, a1) = IM.findMin kindMap
(i2, a2) = IM.findMax kindMap
in ((Id (toEnum i1), a1), (Id (toEnum i2), a2))
in (Id 0, (fst . snd) limits)
, 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."
newtype Array i c = Array (A.UArray i Word.Word8) deriving Show
instance (Ix.Ix i, Binary i) => Binary (Array i c) where
put (Array a) = put a
get = fmap Array get
(!) :: 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