123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151 |
- {-# LANGUAGE OverloadedStrings #-}
- module Potrero.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"
|