wonky but working first pass at a table-rolling application

.gitignore

@@ -0,0 +1,20 @@
+dist
+dist-*
+*~
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+cabal.project.local
+.ghc.environment.*

perilous-wilds.txt

@@ -0,0 +1,124 @@
+dungeon
+    size
+        1-3:   small (2 themes, 6 areas)
+        4-9:   medium (3 themes, 12 areas)
+        10-11: large (4 themes, 16 aras)
+        12:    huge (5 themes, 24 areas)
+    discovery
+        1:   unthemed, common, empty
+        2:   unthemed, common, danger
+        3-4: unthemed, common, danger + discovery
+        5-6: unthemed, common, discovery
+
+        7:  themed, common, danger
+        8:  themed, common, danger + discovery
+        9:  themed, common, discovery
+        10: themed, unique, danger
+        11: themed, unique, danger + discovery
+        12: themed, unique, discovery
+    ruination
+        1:    arcane disaster
+        2:    damnation/curse
+        3-4:  earthquate/fire/flood
+        5-6:  plague/famine/drought
+        7-8:  overrun by monsters
+        9-10: war/invasion
+        11:   depleted resources
+        12:   better prospects elsewhere
+
+    foundation
+        builder
+            1: aliens/precursors
+            2: demigod/demon
+            3-4: natural (caves etc.)
+            5: religious order/cult
+            6-7: humanoid
+            8-9: dwarves/gnomes
+            10: elves
+            11: wizard/madman
+            12: monarch/warlord
+        function
+            1: source/portal
+            2: mine
+            3-4: tomb/crypt
+            5: prison
+            6-7: lair/den/hideout
+            8-9: stronghold/sanctuary
+            10: shrine/temple/oracle
+            11: archive/library
+            12: unknown/mystery
+
+    theme
+        1-5:   @dungeon/theme/mundane
+        6-9:   @dungeon/theme/unusual
+        10-12: @dungeon/theme/extraordinary
+        mundane
+            1:  rot/decay
+            2:  torture/agony
+            3:  madness
+            4:  all is lost
+            5:  noble sacrifice
+            6:  savage fury
+            7:  survival
+            8:  criminal activity
+            9:  secrets/treachery
+            10: tricks and traps
+            11: invasion/infestation
+            12: factions at war
+        unusual
+            1:  creation/invention
+            2:  element
+            3:  knowledge/learning
+            4:  growth/expansion
+            5:  deepening mystery
+            6:  transformation/change
+            7:  chaos and destruction
+            8:  shadowy forces
+            9:  forbidden knowledge
+            10: poison/disease
+            11: corruption/blight
+            12: impending disaster
+        extraordinary
+            1:  scheming evil
+            2:  divination/scrying
+            3:  blasphemy
+            4:  arcane research
+            5:  occult forces
+            6:  an ancient curse
+            7:  mutation
+            8:  the unquiet dead
+            9:  bottomless hunger
+            10: incredible power
+            11: unspeakable horrors
+            12: holy war
+
+    discovery
+        1-3: @dungeon/discovery/dressing
+        dressing
+            1:  junk/debris
+            2:  tracks/marks
+            3:  signs of battle
+            4:  writing/carving
+            5:  warning
+            6:  dead creature
+            7:  bones/remains
+            8:  book/scroll/map
+            9:  broken door/wall
+            10: breeze/wind/smell
+            11: lichen/moss/fungus
+            12: @details/oddity
+
+details
+    oddity
+        1:  weird color/smell/sound
+        2:  geometric
+        3:  web/network/system
+        4:  crystalline/glass-like
+        5:  fungal
+        6:  gaseous/smokey
+        7:  mirage/illusion
+        8:  volcanic/explosive
+        9:  magnetic/repellant
+        10: devoid of life
+        11: unexpectedly alive
+        12: roll twice

potrero.cabal

@@ -0,0 +1,21 @@
+name: potrero
+version: 0.1.0.0
+license: BSD3
+author: Getty Ritter <gettylefou@gmail.com>
+maintainer: Getty Ritter <gettylefou@gmail.com>
+copyright: @2018 Getty Ritter
+build-type: Simple
+cabal-version: >=1.14
+
+executable potrero
+  hs-source-dirs: src
+  main-is: Main.hs
+  other-modules: Types
+                 Parser
+  default-language: Haskell2010
+  ghc-options: -Wall
+  build-depends: base >=4.7 && <5
+               , containers
+               , random
+               , readline
+               , text

src/Main.hs

@@ -0,0 +1,58 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TypeFamilies #-}
+
+module Main where
+
+import qualified Control.Monad as M
+import qualified Data.IORef as IO
+import qualified Data.Map.Strict as Map
+import           Data.Monoid ((<>))
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+import qualified System.Console.Readline as Readline
+import qualified System.Exit as Exit
+
+import qualified Parser
+import qualified Types
+
+readMap :: FilePath -> IO Types.TableMap
+readMap path = do
+  cs <- Text.readFile path
+  pure $ Map.fromList
+    [ (Types.tableName t, t)
+    | t <- Parser.parseTable cs
+    ]
+
+main :: IO ()
+main = do
+  tablesRef <- IO.newIORef =<< readMap "tables.txt"
+  Readline.setCompletionEntryFunction $ Just $ \ rs -> do
+    tables <- IO.readIORef tablesRef
+    pure [ Text.unpack k
+         | k <- Map.keys tables
+         , Text.pack rs `Text.isPrefixOf` k
+         ]
+  M.forever $ do
+    input <- Readline.readline "\x1b[31m--> \x1b[39m"
+    case input of
+      Nothing -> do
+        putStrLn "farewell"
+        Exit.exitSuccess
+      Just "" -> pure ()
+      Just ":l" -> do
+        tables <- IO.readIORef tablesRef
+        Text.putStrLn "Available tables: "
+        Text.putStrLn ("  " <> Text.unwords (Map.keys tables))
+        IO.writeIORef tablesRef =<< readMap "tables.txt"
+      Just ":r" ->
+        IO.writeIORef tablesRef =<< readMap "tables.txt"
+      Just choice -> do
+        tables <- IO.readIORef tablesRef
+        let names = Text.unwords (Map.keys tables)
+        Readline.addHistory choice
+        case Map.lookup (Text.strip (Text.pack choice)) tables of
+          Nothing -> do
+            Text.putStrLn ("table not found: " <> Text.pack (show choice))
+            Text.putStrLn ("  valid tables include: " <> names)
+          Just t -> Types.rollTable tables t

src/Parser.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Parser where
+
+import           Data.Char as Char
+import qualified Data.Text as Text
+
+import Types
+
+data LineType
+  = TableDecl Int Text.Text
+  | TableEntry Range Result
+    deriving (Eq, Show)
+
+indentAmount :: Text.Text -> Int
+indentAmount = Text.length . Text.takeWhile Char.isSpace
+
+parseRange :: Text.Text -> Range
+parseRange t
+  | Text.all Char.isNumber (Text.strip t) =
+    let n = read (Text.unpack t) in Range n n
+  | otherwise =
+    let (x, y) = Text.breakOn "-" (Text.strip t)
+        n = read (Text.unpack x)
+        m = read (Text.unpack (Text.tail y))
+    in Range n m
+
+parseResult :: Text.Text -> Result
+parseResult t
+  | "@" `Text.isPrefixOf` Text.strip t =
+    ResultRoll (Text.tail (Text.strip t))
+  | otherwise =
+    ResultText (Text.strip t)
+
+parseLines :: [Text.Text] -> [LineType]
+parseLines = go
+  where
+     go [] = []
+     go (t:ts)
+       | Text.all Char.isSpace t = go ts
+       | Text.any (== ':') t =
+         let (rangeTxt, message) = Text.breakOn ":" t
+             range = parseRange rangeTxt
+             msg = parseResult (Text.tail message)
+         in TableEntry range msg : go ts
+       | otherwise =
+         TableDecl (indentAmount t) (Text.strip t) : go ts
+
+parseTable :: Text.Text -> [Table]
+parseTable = parseTop [] . parseLines . Text.lines
+  where
+    parseTop _ [] = []
+    parseTop ctx (TableDecl n name:xs) =
+      parseTop ((n, name) : [ c | c <- ctx, fst c < n]) xs
+    parseTop ctx (TableEntry r m:xs) =
+      let (table, rest) = gatherEntries ctx xs [(r, m)]
+      in table : parseTop ctx rest
+    gatherEntries ctx (TableEntry r m:xs) es =
+      gatherEntries ctx xs ((r, m) : es)
+    gatherEntries ctx rs es =
+      let name = Text.intercalate "/" (reverse (map snd ctx))
+      in (Table name (reverse es), rs)

src/Types.hs

@@ -0,0 +1,53 @@
+{-# 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 Result
+  = ResultText Text.Text
+  | ResultRoll Text.Text
+    deriving (Eq, Show)
+
+computeResult :: Int -> TableMap -> Result -> IO ()
+computeResult r _  (ResultText msg) = do
+  Text.putStr ("\x1b[36m" <> Text.pack (show r) <> ":\x1b[39m ")
+  Text.putStrLn msg
+computeResult r ts (ResultRoll name)
+  | Just t <- Map.lookup name ts = do
+      Text.putStr ("\x1b[36m" <> Text.pack (show r))
+      Text.putStrLn (": (roll " <> name <> ")\x1b[39m")
+      rollTable ts t
+  | otherwise = Text.putStrLn ("error: no such table: " <> name)
+
+tableDie :: Table -> Int
+tableDie t = maximum [ x | (Range _ x, _) <- tableChoices t ]
+
+rollTable :: TableMap -> Table -> IO ()
+rollTable tables t = do
+  roll <- Rand.randomRIO (1, tableDie t)
+  case [ result
+       | (range, result) <- tableChoices t
+       , roll >= rFrom range && roll <= rTo range
+       ] of
+    [choice] -> computeResult roll tables choice
+    _ -> Text.putStrLn $ Text.unwords
+           [ "bad table "
+           , tableName t
+           , "(roll of"
+           , Text.pack (show roll)
+           , "has no matching result)"
+           ]