{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes, ScopedTypeVariables, TypeFamilies #-}
-- | General content types and operations.
module Game.LambdaHack.Kind
  ( -- * General content types
    Id, Speedup(..), Ops(..), COps(..), createOps, stdRuleset
    -- * Arrays of content identifiers
  , 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 Data.Text (Text)
import qualified Data.Text as T
import Game.LambdaHack.Msg
import Data.Maybe (fromMaybe)

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

-- | Content identifiers for the content type @c@.
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

-- | Type family for auxiliary data structures for speeding up
-- content operations.
data family Speedup a

data instance Speedup TileKind = TileSpeedup
  { isClearTab :: Id TileKind -> Bool
  , isLitTab   :: Id TileKind -> Bool
  }

-- | Content operations for the content of type @a@.
data Ops a = Ops
  { osymbol :: Id a -> Char       -- ^ the symbol of a content element at id
  , oname :: Id a -> Text         -- ^ the name of a content element at id
  , okind :: Id a -> a            -- ^ the content element at given id
  , ouniqGroup :: Text -> Id a    -- ^ the id of the unique member of
                                  --   a singleton content group
  , opick :: Text -> (a -> Bool) -> Rnd (Id a)
                                  -- ^ pick a random id belonging to a group
                                  --   and satisfying a predicate
  , ofoldrWithKey :: forall b. (Id a -> a -> b -> b) -> b -> b
                                  -- ^ fold over all content elements of @a@
  , obounds :: (Id a, Id a)       -- ^ bounds of identifiers of content @a@
  , ospeedup :: Speedup a         -- ^ auxiliary speedup components
  }

-- | Create content operations for type @a@ from definition of content
-- of type @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 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 (Id i) = fromMaybe (assert `failure` (i, fromEnum i, kindMap))
                     $ IM.lookup (fromEnum 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 not validated: " :: 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
             {- with MonadComprehensions:
             frequency [ i | (i, k) <- kindFreq M.! group, p k ]
             -}
       , 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  -- define elsewhere
       }

-- | Operations for all content types, gathered together.
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)
  }

-- | The standard ruleset used for level operations.
stdRuleset :: Ops RuleKind -> RuleKind
stdRuleset Ops{ouniqGroup, okind} = okind $ ouniqGroup "standard"

instance Show COps where
  show _ = "Game content."

-- | Arrays of content identifiers pointing to the content type @c@,
-- where the identifiers are represented as @Word8@
-- (and so content of type @c@ can have at most 256 elements).
-- The arrays are indexed by type @i@, e.g., a dungeon tile location.
newtype Array i c = Array (A.UArray i Word.Word8) deriving Show

-- TODO: save/restore is still too slow, but we are already past
-- the point of diminishing returns. A dramatic change would be
-- low-level conversion to ByteString and serializing that.
instance (Ix.Ix i, Binary i) => Binary (Array i c) where
  put (Array a) = put a
  get = fmap Array get

-- | Content identifiers array lookup.
(!) :: Ix.Ix i => Array i c -> i -> Id c
(!) (Array a) i = Id $ a A.! i

-- | Construct a content identifiers array updated with the association list.
(//) :: Ix.Ix i => Array i c -> [(i, Id c)] -> Array i c
(//) (Array a) l = Array $ a A.// [(i, e) | (i, Id e) <- l]

-- | Create a content identifiers array from a list of elements.
listArray :: Ix.Ix i => (i, i) -> [Id c] -> Array i c
listArray bds l = Array $ A.listArray bds [e | Id e <- l]

-- | Create a content identifiers array from an association list.
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]

-- | Content identifiers array bounds.
bounds :: Ix.Ix i => Array i c -> (i, i)
bounds (Array a) = A.bounds a

-- | Fold left strictly over an array.
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