{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving, TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Game.LambdaHack.Common.Misc
(
FactionId, LevelId, ActorId
, Container(..), CStore(..), SLore(..), ItemDialogMode(..)
, GroupName, Tactic(..)
, toGroupName, describeTactic
, makePhrase, makeSentence, squashedWWandW, normalLevelBound
, appDataDir, xM, xD, minusM, minusM1, oneM, tenthM
) where
import Prelude ()
import Game.LambdaHack.Common.Prelude
import Control.DeepSeq
import Data.Binary
import qualified Data.Char as Char
import qualified Data.EnumMap.Strict as EM
import qualified Data.EnumSet as ES
import qualified Data.Fixed as Fixed
import Data.Hashable
import qualified Data.HashMap.Strict as HM
import Data.Int (Int64)
import Data.Key
import Data.String (IsString (..))
import qualified Data.Text as T
import qualified Data.Time as Time
import GHC.Generics (Generic)
import qualified NLP.Miniutter.English as MU
import System.Directory (getAppUserDataDirectory)
import System.Environment (getProgName)
import Game.LambdaHack.Common.Point
newtype FactionId = FactionId Int
deriving (Show, Eq, Ord, Enum, Hashable, Binary)
newtype LevelId = LevelId Int
deriving (Show, Eq, Ord, Hashable, Binary)
instance Enum LevelId where
fromEnum (LevelId n) = n
toEnum = LevelId
newtype ActorId = ActorId Int
deriving (Show, Eq, Ord, Enum, Binary)
data Container =
CFloor LevelId Point
| CEmbed LevelId Point
| CActor ActorId CStore
| CTrunk FactionId LevelId Point
deriving (Show, Eq, Ord, Generic)
instance Binary Container
data CStore =
CGround
| COrgan
| CEqp
| CInv
| CSha
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
instance Binary CStore
instance NFData CStore
data SLore =
SItem
| SOrgan
| STrunk
| STmp
| SBlast
| SEmbed
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
instance Binary SLore
instance NFData SLore
data ItemDialogMode = MStore CStore | MOrgans | MOwned | MStats | MLore SLore
deriving (Show, Read, Eq, Ord, Generic)
instance NFData ItemDialogMode
instance Binary ItemDialogMode
newtype GroupName a = GroupName Text
deriving (Read, Eq, Ord, Hashable, Binary, Generic)
instance IsString (GroupName a) where
fromString = GroupName . T.pack
instance Show (GroupName a) where
show (GroupName gn) = T.unpack gn
instance NFData (GroupName a)
data Tactic =
TExplore
| TFollow
| TFollowNoItems
| TMeleeAndRanged
| TMeleeAdjacent
| TBlock
| TRoam
| TPatrol
deriving (Eq, Ord, Enum, Bounded, Generic)
instance Show Tactic where
show TExplore = "explore"
show TFollow = "follow freely"
show TFollowNoItems = "follow only"
show TMeleeAndRanged = "fight only"
show TMeleeAdjacent = "melee only"
show TBlock = "block only"
show TRoam = "roam freely"
show TPatrol = "patrol area"
instance Binary Tactic
instance NFData Tactic
toGroupName :: Text -> GroupName a
{-# INLINE toGroupName #-}
toGroupName = GroupName
describeTactic :: Tactic -> Text
describeTactic TExplore = "investigate unknown positions, chase targets"
describeTactic TFollow = "follow leader's target or position, grab items"
describeTactic TFollowNoItems =
"follow leader's target or position, ignore items"
describeTactic TMeleeAndRanged =
"engage in both melee and ranged combat, don't move"
describeTactic TMeleeAdjacent = "engage exclusively in melee, don't move"
describeTactic TBlock = "block and wait, don't move"
describeTactic TRoam = "move freely, chase targets"
describeTactic TPatrol = "find and patrol an area (WIP)"
makePhrase, makeSentence :: [MU.Part] -> Text
makePhrase = MU.makePhrase MU.defIrregular
makeSentence = MU.makeSentence MU.defIrregular
squashedWWandW :: [MU.Part] -> (MU.Part, MU.Person)
squashedWWandW parts =
let repetitions = group parts
f [] = error $ "empty group" `showFailure` parts
f [part] = (part, MU.Sg3rd)
f l@(part : _) = (MU.CardinalWs (length l) part, MU.PlEtc)
cars = map f repetitions
person = case cars of
[] -> error $ "empty cars" `showFailure` parts
[(_, person1)] -> person1
_ -> MU.PlEtc
in (MU.WWandW $ map fst cars, person)
normalLevelBound :: (Int, Int)
normalLevelBound = (79, 20)
appDataDir :: IO FilePath
appDataDir = do
progName <- getProgName
let name = takeWhile Char.isAlphaNum progName
getAppUserDataDirectory name
xM :: Int -> Int64
xM k = fromIntegral k * 1000000
xD :: Double -> Double
xD k = k * 1000000
minusM, minusM1, oneM, tenthM :: Int64
minusM = xM (-1)
minusM1 = xM (-1) - 1
oneM = xM 1
tenthM = 100000
instance (Enum k, Binary k, Binary e) => Binary (EM.EnumMap k e) where
put m = put (EM.size m) >> mapM_ put (EM.toAscList m)
get = EM.fromDistinctAscList <$> get
instance (Enum k, Binary k) => Binary (ES.EnumSet k) where
put m = put (ES.size m) >> mapM_ put (ES.toAscList m)
get = ES.fromDistinctAscList <$> get
instance Binary Time.NominalDiffTime where
get = fmap realToFrac (get :: Get Fixed.Pico)
put = (put :: Fixed.Pico -> Put) . realToFrac
instance (Hashable k, Eq k, Binary k, Binary v) => Binary (HM.HashMap k v) where
get = fmap HM.fromList get
put = put . HM.toList
type instance Key (EM.EnumMap k) = k
instance Zip (EM.EnumMap k) where
{-# INLINE zipWith #-}
zipWith = EM.intersectionWith
instance Enum k => ZipWithKey (EM.EnumMap k) where
{-# INLINE zipWithKey #-}
zipWithKey = EM.intersectionWithKey
instance Enum k => Keyed (EM.EnumMap k) where
{-# INLINE mapWithKey #-}
mapWithKey = EM.mapWithKey
instance Enum k => FoldableWithKey (EM.EnumMap k) where
{-# INLINE foldrWithKey #-}
foldrWithKey = EM.foldrWithKey
instance Enum k => TraversableWithKey (EM.EnumMap k) where
traverseWithKey f = fmap EM.fromDistinctAscList
. traverse (\(k, v) -> (,) k <$> f k v) . EM.toAscList
instance Enum k => Indexable (EM.EnumMap k) where
{-# INLINE index #-}
index = (EM.!)
instance Enum k => Lookup (EM.EnumMap k) where
{-# INLINE lookup #-}
lookup = EM.lookup
instance Enum k => Adjustable (EM.EnumMap k) where
{-# INLINE adjust #-}
adjust = EM.adjust
instance (Enum k, Hashable k, Hashable e) => Hashable (EM.EnumMap k e) where
hashWithSalt s x = hashWithSalt s (EM.toAscList x)
instance NFData MU.Part
instance NFData MU.Person
instance NFData MU.Polarity