potrero/src/Types.hs

{-# LANGUAGE OverloadedStrings #-}

module Types where

import qualified Data.Map.Strict as Map
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified System.Random as Rand

data Range = Range { rFrom :: Int, rTo :: Int }
  deriving (Eq, Show)

type TableMap = Map.Map Text.Text 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)

data Value = Value
  { valueMsg :: Text.Text
  } deriving (Eq, Show)

stripValue :: Value -> Value
stripValue = Value . Text.strip . valueMsg

data Context = Context
  { ctxMap  :: TableMap
  , ctxRoll :: Int
  , ctxSelf :: Text.Text
  }

findTable :: Text.Text -> Context -> Maybe Table
findTable name ctx = Map.lookup name (ctxMap ctx)

computeFragments :: Context -> Fragment -> IO Value
computeFragments _ (FragText msg) = pure (Value 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 -> error ("no such table: " ++ show absolute)

computeResult :: Context -> Result -> IO Value
computeResult ctx (Result msgs) = do
  vs <- mapM (computeFragments ctx) msgs
  pure (Value (foldMap valueMsg vs))

tableDie :: Table -> Int
tableDie t = maximum [ x | (Range _ x, _) <- tableChoices t ]

rollTable :: TableMap -> Table -> IO Value
rollTable tables t = do
  roll <- Rand.randomRIO (1, tableDie t)
  let 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 $ unwords
           [ "bad table "
           , Text.unpack (tableName t)
           , "(roll of"
           , show roll
           , "has no matching result)"
           ]