{-# LANGUAGE OverloadedStrings #-}
module Types where
import qualified Control.Exception as Exn
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified System.Random as Rand
type TableName = Text.Text
type Roll = Int
data Range = Range { rFrom :: Roll, rTo :: Roll }
deriving (Eq, Show)
class Exn.Exception t => PotreroError t where
potreroMessage :: t -> [Text.Text]
data BadTable = BadTable
{ badTableTable :: Table
, badTableIndex :: [Int]
} deriving (Eq, Show)
instance Exn.Exception BadTable where
instance PotreroError BadTable where
potreroMessage bt =
let rolls = map (Text.pack . show) (badTableIndex bt)
results = [ "`" <> Text.strip (showResult r) <> "`"
| (Range x y, r) <- tableChoices (badTableTable bt)
, or [ i >= x && i <= y | i <- badTableIndex bt]
]
orText = Text.intercalate " or "
in [ "Malformed table: `" <> tableName (badTableTable bt) <> "`"
, " a roll of " <> orText rolls <> " is ambiguous"
, " and may result in either " <> orText results
]
-- needed to handle d66 tables
rangeMap :: Table -> [(Range, Result)] -> [Int]
rangeMap t ranges = Set.toList (go Set.empty ranges)
where
go set [] = set
go set ((Range x y, _result):rs) =
let rangeSet = Set.fromList [x..y]
overlap = Set.intersection rangeSet set
in if Set.null overlap
then go (Set.union rangeSet set) rs
else Exn.throw (BadTable t (Set.toList overlap))
type TableMap = Map.Map TableName Table
data Table = Table
{ tableName :: Text.Text
, tableChoices :: [(Range, Result)]
} deriving (Eq, Show)
data Fragment
= FragText Text.Text
| FragRoll Text.Text
deriving (Eq, Show)
data Result = Result { fromResult :: [Fragment] }
deriving (Eq, Show)
showResult :: Result -> Text.Text
showResult = foldMap go . fromResult
where go (FragText t) = t
go (FragRoll n) = "@{" <> n <> "}"
-- * Values
data Value = Value
{ valueMsg :: Text.Text
, valueFrom :: TableName
, valueResult :: Roll
, valueSources :: [Value]
} deriving (Eq, Show)
concatValues :: Context -> [Value] -> Value
concatValues _ [v] = v
concatValues Context { ctxSelf = table, ctxRoll = roll } vs = Value
{ valueMsg = foldMap valueMsg vs
, valueFrom = table
, valueResult = roll
, valueSources = vs
}
bareValue :: Context -> Text.Text -> Value
bareValue Context { ctxSelf = table, ctxRoll = roll } text = Value
{ valueMsg = text
, valueFrom = table
, valueResult = roll
, valueSources = []
}
stripValue :: Value -> Value
stripValue value = value { valueMsg = Text.strip (valueMsg value) }
-- * Exceptions
data NoSuchTable = NoSuchTable Text.Text
deriving (Eq, Show)
instance Exn.Exception NoSuchTable where
-- * Context
data Context = Context
{ ctxMap :: TableMap
, ctxRoll :: Int
, ctxSelf :: Text.Text
}
-- * Evaluating Tables
findTable :: Text.Text -> Context -> Maybe Table
findTable name ctx = Map.lookup name (ctxMap ctx)
computeFragments :: Context -> Fragment -> IO Value
computeFragments ctx (FragText msg) = pure (bareValue ctx msg)
computeFragments ctx (FragRoll name) =
let absolute = case Text.stripPrefix "self" name of
Just rest -> ctxSelf ctx <> rest
Nothing -> name
in case findTable absolute ctx of
Just t -> rollTable (ctxMap ctx) t
Nothing -> Exn.throwIO (NoSuchTable absolute)
computeResult :: Context -> Result -> IO Value
computeResult ctx (Result msgs) = do
vs <- mapM (computeFragments ctx) msgs
pure (concatValues ctx vs)
rollTable :: TableMap -> Table -> IO Value
rollTable tables t = do
let rmap = rangeMap t (tableChoices t)
rollIdx <- Rand.randomRIO (0, length rmap - 1)
let roll = rmap !! rollIdx
ctx = Context
{ ctxMap = tables
, ctxRoll = roll
, ctxSelf = tableName t
}
case [ result
| (range, result) <- tableChoices t
, roll >= rFrom range && roll <= rTo range
] of
[choice] -> stripValue <$> computeResult ctx choice
_ -> error "unreachable"