rolling/src/Rolling/Render.hs

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)