potrero/src/Potrero/Types.hs

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