Browse Source

actually apply some software engineering to this code

Getty Ritter 9 months ago
parent
commit
9b1a0c01eb
10 changed files with 228 additions and 120 deletions
  1. 1 0
      .gitignore
  2. 8 0
      rolling.cabal
  3. 31 120
      src/Main.hs
  4. 19 0
      src/Rolling/Common.hs
  5. 18 0
      src/Rolling/FITD.hs
  6. 16 0
      src/Rolling/Ironsworn.hs
  7. 15 0
      src/Rolling/PBTA.hs
  8. 9 0
      src/Rolling/PBTA20.hs
  9. 43 0
      src/Rolling/Prob.hs
  10. 68 0
      src/Rolling/Render.hs

+ 1 - 0
.gitignore

@@ -18,3 +18,4 @@ cabal.sandbox.config
 *.eventlog
 cabal.project.local
 .ghc.environment.*
+*.png

+ 8 - 0
rolling.cabal

@@ -13,6 +13,14 @@ cabal-version: >=1.14
 executable rolling
   hs-source-dirs: src
   main-is: Main.hs
+  other-modules: Rolling.Prob
+               , Rolling.Common
+               , Rolling.Render
+               -- and the games
+               , Rolling.PBTA
+               , Rolling.FITD
+               , Rolling.PBTA20
+               , Rolling.Ironsworn
   default-language: Haskell2010
   default-extensions: ScopedTypeVariables
   ghc-options: -Wall

+ 31 - 120
src/Main.hs

@@ -1,125 +1,36 @@
 module Main where
 
-import qualified Control.Monad.IO.Class as Monad
-import qualified Control.Monad as Monad
-import GHC.Exts (groupWith)
-import qualified Graphics.Rendering.Cairo as Cairo
-import qualified Graphics.Rendering.Pango as Pango
-
-data P = P Int Int deriving (Eq, Ord)
-
-instance Show P where
-  show (P n t) = show n ++ " in " ++ show t
-
-times :: P -> P -> P
-P a at `times` P b bt = P (a * b) (at * bt)
-
-combine :: [P] -> P
-combine ps =
-  let tots = [ t | P _ t <- ps ]
-      newTot = foldr lcm 1 tots
-      newNums = [ if t == newTot then n else error "???" | P n t <- ps ]
-  in P (sum newNums) newTot
-
-newtype Prob a = Prob { unprob :: [(a, P)] } deriving (Eq, Show)
-
-instance Functor Prob where
-  fmap f (Prob xs) = Prob [(f x, p) | (x, p) <- xs]
-
-instance Applicative Prob where
-  pure x = Prob [(x, P 1 1)]
-  Prob fs <*> Prob xs = Prob [(f x, pf `times` px) | (f, pf) <- fs, (x, px) <- xs]
-
-instance Monad Prob where
-  Prob xs >>= f =
-    Prob [ (y, p `times` p')
-         | (x, p) <- xs
-         , (y, p') <- unprob (f x)
-         ]
-
-die :: Int -> Prob Int
-die n = Prob [(d, P 1 n) | d <- [1..n]]
-
-data Result = Success | Partial | Failure deriving (Eq, Show, Ord)
-
-judge :: Int -> Result
-judge n
-  | n <= 6 = Failure
-  | n <= 9 = Partial
-  | otherwise = Success
-
-normalize :: (Ord a) => Prob a -> Prob a
-normalize (Prob xs) =
-  Prob [(fst (head rs), combine (map snd rs)) | rs <- groupWith fst xs ]
-
-roll :: Int -> Prob Result
-roll m = normalize $ do
-  a <- die 6
-  b <- die 6
-  return (judge (a + b + m))
-
-modRoll :: Int -> Prob Result
-modRoll m = normalize $ do
-  a <- die 20
-  let r = a + m
-  return (if r < 10 then Failure else if r < 16 then Partial else Success)
-
-find :: Result -> Prob Result -> Double
-find r (Prob rs) = case [ fromIntegral n / fromIntegral t | (r', P n t) <- rs, r == r' ] of
-  [x] -> x
-  _   -> 0.0
-
-renderRow :: Prob Result -> Int -> Cairo.Render ()
-renderRow results offset = do
-  let f = find Failure results
-      p = find Partial results
-      s = find Success results
-      o = 50.0 * fromIntegral offset + 5
-
-  Cairo.rectangle 5 o (f * 290) 40
-  Cairo.setSourceRGB 1.0 0.0 0.0
-  Cairo.fill
-
-  Cairo.rectangle (5 + f * 290) o (p * 290) 40
-  Cairo.setSourceRGB 1.0 1.0 0.0
-  Cairo.fill
-
-  Cairo.rectangle (5 + (f + p) * 290) o (s * 290) 40
-  Cairo.setSourceRGB 0.0 0.0 1.0
-  Cairo.fill
-
-  Cairo.setSourceRGB 0.0 0.0 0.0
-  layout <- text ("+" ++ show offset)
-  Cairo.moveTo 310.0 (50.0 * fromIntegral offset)
-  Pango.showLayout layout
-
-text :: String -> Cairo.Render Pango.PangoLayout
-text t = do
-  layout <- Pango.createLayout t
-  Monad.liftIO $ do
-    font <- Pango.fontDescriptionNew
-    Pango.fontDescriptionSetFamily font "Fira Sans"
-    Pango.fontDescriptionSetSize font 30
-    Pango.layoutSetFontDescription layout (Just font)
-  return layout
+import Rolling.Common
+import qualified Rolling.Render as Render
 
+import qualified Rolling.PBTA as PBTA
+import qualified Rolling.FITD as FITD
+import qualified Rolling.PBTA20 as PBTA20
+import qualified Rolling.Ironsworn as Ironsworn
 
 main :: IO ()
-main = do
-  let results = [ (n, roll n) | n <- [0..5] ]
-      width = 400
-      height = length results * 50 + 50
-  surface <- Cairo.createImageSurface Cairo.FormatRGB24 width height
-  Cairo.renderWith surface $ do
-    Cairo.setSourceRGB 1.0 1.0 1.0
-    Cairo.rectangle 0.0 0.0 (fromIntegral width) (fromIntegral height)
-    Cairo.fill
-
-    Monad.forM_ results $ \(n, r) ->
-      renderRow r n
-
-    Cairo.setSourceRGB 0.0 0.0 0.0
-    layout <- text "PbtA rolls (2d6)"
-    Cairo.moveTo 20 (fromIntegral height - 50)
-    Pango.showLayout layout
-  Cairo.surfaceWriteToPNG surface "output.png"
+main = mapM_ Render.diagram diagrams
+
+diagrams :: [Diagram]
+diagrams =
+  [ Diagram
+      { title = "PbtA rolls (2d6)"
+      , filename = "pbta.png"
+      , rolls = [ (n, PBTA.roll n) | n <- [0..5] ]
+      }
+  , Diagram
+      { title = "FitD roll (d6 pool)"
+      , filename = "fitd.png"
+      , rolls = [ (n, FITD.roll n) | n <- [0..5] ]
+      }
+  , Diagram
+      { title = "PbtA-ish roll (d20)"
+      , filename = "d20.png"
+      , rolls = [ (n, PBTA20.roll n) | n <- [0..10] ]
+      }
+  , Diagram
+      { title = "Ironsworn roll"
+      , filename = "ironsworn.png"
+      , rolls = [ (n, Ironsworn.roll n) | n <- [0..5] ]
+      }
+  ]

+ 19 - 0
src/Rolling/Common.hs

@@ -0,0 +1,19 @@
+module Rolling.Common (Diagram(..), Prob, Result(..), normalize, die) where
+
+import Rolling.Prob
+
+data Diagram = Diagram
+  { title :: String
+  , filename :: String
+  , rolls :: [(Int, Prob Result)]
+  }
+
+die :: Int -> Prob Int
+die n = Prob [(d, P 1 n) | d <- [1..n]]
+
+-- the success metric for vaguely PbtA-ish games
+data Result
+  = Success
+  | Partial
+  | Failure
+  deriving (Eq, Show, Ord)

+ 18 - 0
src/Rolling/FITD.hs

@@ -0,0 +1,18 @@
+module Rolling.FITD (roll) where
+
+import Rolling.Common
+
+judge :: Int -> Result
+judge n
+  | n <= 3 = Failure
+  | n <= 5 = Partial
+  | otherwise = Success
+
+roll :: Int -> Prob Result
+roll 0 = normalize $ do
+  a <- die 6
+  b <- die 6
+  return (judge (a `min` b))
+roll n = normalize $ do
+  dice <- sequence [ die 6 | _ <- [1..n] ]
+  return (judge (maximum dice))

+ 16 - 0
src/Rolling/Ironsworn.hs

@@ -0,0 +1,16 @@
+module Rolling.Ironsworn (roll) where
+
+import Rolling.Common
+
+judge :: Int -> Int -> Int -> Result
+judge r a b
+  | r < a && r < b = Failure
+  | r < a || r < b = Partial
+  | otherwise = Success
+
+roll :: Int -> Prob Result
+roll m = normalize $ do
+  r <- die 6
+  a <- die 10
+  b <- die 10
+  return (judge (r + m) a b)

+ 15 - 0
src/Rolling/PBTA.hs

@@ -0,0 +1,15 @@
+module Rolling.PBTA (roll) where
+
+import Rolling.Common
+
+judge :: Int -> Result
+judge n
+  | n <= 6 = Failure
+  | n <= 9 = Partial
+  | otherwise = Success
+
+roll :: Int -> Prob Result
+roll m = normalize $ do
+  a <- die 6
+  b <- die 6
+  return (judge (a + b + m))

+ 9 - 0
src/Rolling/PBTA20.hs

@@ -0,0 +1,9 @@
+module Rolling.PBTA20 (roll) where
+
+import Rolling.Common
+
+roll :: Int -> Prob Result
+roll m = normalize $ do
+  a <- die 20
+  let r = a + m
+  return (if r < 10 then Failure else if r < 16 then Partial else Success)

+ 43 - 0
src/Rolling/Prob.hs

@@ -0,0 +1,43 @@
+module Rolling.Prob where
+
+import GHC.Exts (groupWith)
+
+-- a probability expressed as a ratio (i.e. @P 1 2@ is a 50/50 chance)
+data P = P Int Int deriving (Eq, Ord)
+
+instance Show P where
+  show (P n t) = show n ++ " in " ++ show t
+
+times :: P -> P -> P
+P a at `times` P b bt = P (a * b) (at * bt)
+
+combine :: [P] -> P
+combine ps =
+  let tots = [ t | P _ t <- ps ]
+      newTot = foldr lcm 1 tots
+      newNums = [ if t == newTot then n else error "FIXME" | P n t <- ps ]
+  in P (sum newNums) newTot
+
+
+-- a Prob monad that tracks possible things with their probabilities
+newtype Prob a = Prob { unprob :: [(a, P)] } deriving (Eq, Show)
+
+instance Functor Prob where
+  fmap f (Prob xs) = Prob [(f x, p) | (x, p) <- xs]
+
+instance Applicative Prob where
+  pure x = Prob [(x, P 1 1)]
+  Prob fs <*> Prob xs = Prob [(f x, pf `times` px) | (f, pf) <- fs, (x, px) <- xs]
+
+instance Monad Prob where
+  Prob xs >>= f =
+    Prob [ (y, p `times` p')
+         | (x, p) <- xs
+         , (y, p') <- unprob (f x)
+         ]
+
+-- probably the wrong name? this is collapsing identical possibilities
+-- into one
+normalize :: (Ord a) => Prob a -> Prob a
+normalize (Prob xs) =
+  Prob [(fst (head rs), combine (map snd rs)) | rs <- groupWith fst xs ]

+ 68 - 0
src/Rolling/Render.hs

@@ -0,0 +1,68 @@
+module Rolling.Render (diagram) where
+
+import qualified Control.Monad.IO.Class as Monad
+import qualified Control.Monad as Monad
+import qualified Graphics.Rendering.Cairo as Cairo
+import qualified Graphics.Rendering.Pango as Pango
+
+import Rolling.Common
+import Rolling.Prob
+
+findProb :: Result -> Prob Result -> Double
+findProb r (Prob rs) = case [ fromIntegral n / fromIntegral t | (r', P n t) <- rs, r == r' ] of
+  [x] -> x
+  _   -> 0.0
+
+renderRow :: Prob Result -> Int -> Cairo.Render ()
+renderRow results offset = do
+  let f = findProb Failure results
+      p = findProb Partial results
+      s = findProb Success results
+      o = 50.0 * fromIntegral offset + 5
+
+  Cairo.rectangle 5 o (f * 290) 40
+  Cairo.setSourceRGB 1.0 0.0 0.0
+  Cairo.fill
+
+  Cairo.rectangle (5 + f * 290) o (p * 290) 40
+  Cairo.setSourceRGB 1.0 1.0 0.0
+  Cairo.fill
+
+  Cairo.rectangle (5 + (f + p) * 290) o (s * 290) 40
+  Cairo.setSourceRGB 0.0 0.0 1.0
+  Cairo.fill
+
+  Cairo.setSourceRGB 0.0 0.0 0.0
+  layout <- text ("+" ++ show offset)
+  Cairo.moveTo 310.0 (50.0 * fromIntegral offset)
+  Pango.showLayout layout
+
+text :: String -> Cairo.Render Pango.PangoLayout
+text t = do
+  layout <- Pango.createLayout t
+  Monad.liftIO $ do
+    font <- Pango.fontDescriptionNew
+    Pango.fontDescriptionSetFamily font "Fira Sans"
+    Pango.fontDescriptionSetSize font 30
+    Pango.layoutSetFontDescription layout (Just font)
+  return layout
+
+diagram :: Diagram -> IO ()
+diagram d = do
+  let results = rolls d
+      width = 400
+      height = length results * 50 + 50
+  surface <- Cairo.createImageSurface Cairo.FormatRGB24 width height
+  Cairo.renderWith surface $ do
+    Cairo.setSourceRGB 1.0 1.0 1.0
+    Cairo.rectangle 0.0 0.0 (fromIntegral width) (fromIntegral height)
+    Cairo.fill
+
+    Monad.forM_ results $ \(n, r) ->
+      renderRow r n
+
+    Cairo.setSourceRGB 0.0 0.0 0.0
+    layout <- text (title d)
+    Cairo.moveTo 20 (fromIntegral height - 50)
+    Pango.showLayout layout
+  Cairo.surfaceWriteToPNG surface (filename d)