gdritter repos potrero / 727aedb
Add a Value type to try to keep track of roll history Getty Ritter 5 years ago
2 changed file(s) with 80 addition(s) and 11 deletion(s). Collapse all Expand all
+36
-3
src/Main.hs less more
1111 import qualified Data.Text as Text
1212 import qualified Data.Text.IO as Text
1313 import qualified System.Console.Readline as Readline
14 import qualified System.Environment as Env
1415 import qualified System.Exit as Exit
1516
1617 import qualified Parser
2728
2829 main :: IO ()
2930 main = do
30 tablesRef <- IO.newIORef =<< readMap "perilous-wilds.txt"
31 args <- Env.getArgs
32 let filename = case args of
33 path:_ -> path
34 _ -> "perilous-wilds.txt"
35 tablesRef <- IO.newIORef =<< readMap filename
3136 Readline.setCompletionEntryFunction $ Just $ \ rs -> do
3237 tables <- IO.readIORef tablesRef
3338 pure [ Text.unpack k
5156 Text.putStrLn "Available tables: "
5257 Text.putStrLn (" " <> Text.unwords (Map.keys tables))
5358 Just ":r" ->
54 IO.writeIORef tablesRef =<< readMap "perilous-wilds.txt"
59 IO.writeIORef tablesRef =<< readMap filename
5560
5661 Just choice -> do
5762 tables <- IO.readIORef tablesRef
6166 Nothing -> do
6267 Text.putStrLn ("table not found: " <> Text.pack (show choice))
6368 Text.putStrLn (" valid tables include: " <> names)
64 Just t -> Types.rollTable tables t >>= (Text.putStrLn . Types.valueMsg)
69 Just t -> do
70 v <- Types.rollTable tables t
71 showValueAndRolls v
72
73 -- | simply show the value generated
74 showValue :: Types.Value -> IO ()
75 showValue value = Text.putStrLn (Types.valueMsg value)
76
77 -- | pretty-print the value as well as each roll that was done on an
78 -- intermediate table
79 showValueAndRolls :: Types.Value -> IO ()
80 showValueAndRolls value = go 0 value
81 where
82 go n v
83 | Text.null (Text.strip (Types.valueMsg v)) = pure ()
84 | otherwise = do
85 Text.putStr "\x1b[36m"
86 Text.putStr (Text.replicate (n+1) " ")
87 putStr (show (Types.valueResult v))
88 Text.putStr " on "
89 Text.putStr (Types.valueFrom v)
90 M.when (null (Types.valueSources v)) $ do
91 Text.putStr ": \""
92 Text.putStr (Text.strip (Types.valueMsg v))
93 Text.putStr "\""
94 Text.putStrLn "\x1b[39m"
95 mapM_ (go (n+1)) (Types.valueSources v)
96 M.when (n == 0) $
97 Text.putStrLn (Types.valueMsg v)
+44
-8
src/Types.hs less more
22
33 module Types where
44
5 import qualified Control.Exception as Exn
56 import qualified Data.Map.Strict as Map
67 import qualified Data.Text as Text
7 import qualified Data.Text.IO as Text
88 import qualified System.Random as Rand
99
10 data Range = Range { rFrom :: Int, rTo :: Int }
10 type TableName = Text.Text
11 type Roll = Int
12
13 data Range = Range { rFrom :: Roll, rTo :: Roll }
1114 deriving (Eq, Show)
1215
13 type TableMap = Map.Map Text.Text Table
16 type TableMap = Map.Map TableName Table
1417
1518 data Table = Table
1619 { tableName :: Text.Text
2528 data Result = Result { fromResult :: [Fragment] }
2629 deriving (Eq, Show)
2730
31 -- * Values
32
2833 data Value = Value
29 { valueMsg :: Text.Text
34 { valueMsg :: Text.Text
35 , valueFrom :: TableName
36 , valueResult :: Roll
37 , valueSources :: [Value]
3038 } deriving (Eq, Show)
3139
40 concatValues :: Context -> [Value] -> Value
41 concatValues _ [v] = v
42 concatValues Context { ctxSelf = table, ctxRoll = roll } vs = Value
43 { valueMsg = foldMap valueMsg vs
44 , valueFrom = table
45 , valueResult = roll
46 , valueSources = vs
47 }
48
49 bareValue :: Context -> Text.Text -> Value
50 bareValue Context { ctxSelf = table, ctxRoll = roll } text = Value
51 { valueMsg = text
52 , valueFrom = table
53 , valueResult = roll
54 , valueSources = []
55 }
56
3257 stripValue :: Value -> Value
33 stripValue = Value . Text.strip . valueMsg
58 stripValue value = value { valueMsg = Text.strip (valueMsg value) }
59
60 -- * Exceptions
61
62 data NoSuchTable = NoSuchTable Text.Text
63 deriving (Eq, Show)
64
65 instance Exn.Exception NoSuchTable where
66
67 -- * Context
3468
3569 data Context = Context
3670 { ctxMap :: TableMap
3872 , ctxSelf :: Text.Text
3973 }
4074
75 -- * Evaluating Tables
76
4177 findTable :: Text.Text -> Context -> Maybe Table
4278 findTable name ctx = Map.lookup name (ctxMap ctx)
4379
4480 computeFragments :: Context -> Fragment -> IO Value
45 computeFragments _ (FragText msg) = pure (Value msg)
81 computeFragments ctx (FragText msg) = pure (bareValue ctx msg)
4682 computeFragments ctx (FragRoll name) =
4783 let absolute = case Text.stripPrefix "self" name of
4884 Just rest -> ctxSelf ctx <> rest
4985 Nothing -> name
5086 in case findTable absolute ctx of
5187 Just t -> rollTable (ctxMap ctx) t
52 Nothing -> error ("no such table: " ++ show absolute)
88 Nothing -> Exn.throwIO (NoSuchTable absolute)
5389
5490 computeResult :: Context -> Result -> IO Value
5591 computeResult ctx (Result msgs) = do
5692 vs <- mapM (computeFragments ctx) msgs
57 pure (Value (foldMap valueMsg vs))
93 pure (concatValues ctx vs)
5894
5995 tableDie :: Table -> Int
6096 tableDie t = maximum [ x | (Range _ x, _) <- tableChoices t ]