Render.hs 2.4 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980
  1. {-# LANGUAGE NamedFieldPuns #-}
  2. module Rolling.Render (diagramPbtA, diagram) where
  3. import qualified Control.Monad as Monad
  4. import qualified Control.Monad.IO.Class as Monad
  5. import qualified Graphics.Rendering.Cairo as Cairo
  6. import qualified Graphics.Rendering.Pango as Pango
  7. import Rolling.Common
  8. import Rolling.Prob
  9. findProb :: Result -> Prob Result -> Double
  10. findProb r (Prob rs) = case [fromIntegral n / fromIntegral t | (r', P n t) <- rs, r == r'] of
  11. [x] -> x
  12. _ -> 0.0
  13. renderRow :: Prob Result -> Int -> Cairo.Render ()
  14. renderRow results offset = do
  15. let f = findProb Failure results
  16. p = findProb Partial results
  17. s = findProb Success results
  18. o = 50.0 * fromIntegral offset + 5
  19. Cairo.rectangle 5 o (f * 290) 40
  20. Cairo.setSourceRGB 1.0 0.0 0.0
  21. Cairo.fill
  22. Cairo.rectangle (5 + f * 290) o (p * 290) 40
  23. Cairo.setSourceRGB 1.0 1.0 0.0
  24. Cairo.fill
  25. Cairo.rectangle (5 + (f + p) * 290) o (s * 290) 40
  26. Cairo.setSourceRGB 0.0 0.0 1.0
  27. Cairo.fill
  28. Cairo.setSourceRGB 0.0 0.0 0.0
  29. layout <- text ("+" ++ show offset)
  30. Cairo.moveTo 310.0 (50.0 * fromIntegral offset)
  31. Pango.showLayout layout
  32. text :: String -> Cairo.Render Pango.PangoLayout
  33. text t = do
  34. layout <- Pango.createLayout t
  35. Monad.liftIO $ do
  36. font <- Pango.fontDescriptionNew
  37. Pango.fontDescriptionSetFamily font "Fira Sans"
  38. Pango.fontDescriptionSetSize font 30
  39. Pango.layoutSetFontDescription layout (Just font)
  40. return layout
  41. diagramPbtA :: String -> String -> [(Int, Prob Result)] -> IO ()
  42. diagramPbtA title filename results = do
  43. let width = 380
  44. height = length results * 50 + 50
  45. surface <- Cairo.createImageSurface Cairo.FormatRGB24 width height
  46. Cairo.renderWith surface $ do
  47. Cairo.setSourceRGB 1.0 1.0 1.0
  48. Cairo.rectangle 0.0 0.0 (fromIntegral width) (fromIntegral height)
  49. Cairo.fill
  50. Monad.forM_ results $ \(n, r) ->
  51. renderRow r n
  52. Monad.forM_ [0.0, 0.25, 0.5, 0.75, 1.0] $ \rat -> do
  53. let x = 5 + 290 * rat
  54. Cairo.setSourceRGB 0.0 0.0 0.0
  55. Cairo.moveTo x 5
  56. Cairo.lineTo x (fromIntegral (length results) * 50 - 5)
  57. Cairo.stroke
  58. Cairo.setSourceRGB 0.0 0.0 0.0
  59. layout <- text title
  60. Cairo.moveTo 20 (fromIntegral height - 50)
  61. Pango.showLayout layout
  62. Cairo.surfaceWriteToPNG surface filename
  63. diagram :: Diagram -> IO ()
  64. diagram Diagram {title, filename, rolls, render} =
  65. render title filename rolls