potrero/src/Types.hs

{-# 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)

-- needed to handle d66 tables
rangeMap :: [Range] -> [Int]
rangeMap = Set.toList . foldr (Set.union . toSet) Set.empty
  where toSet (Range x y) = Set.fromList [x..y]

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)

-- * 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 (map fst (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 $ unwords
          [ "bad table "
          , Text.unpack (tableName t)
          , "(roll of"
          , show roll
          , "has no matching result)"
          ]
    _ -> error "ambiguous result (TODO)"