cairo: ruled notebook drawing example

drawnotebook.hs

module Main where

import Control.Applicative 

import System.IO
import System.Environment 
import Graphics.Rendering.Cairo

data RGBA = RGBA { 
  colorR :: Double, 
  colorG :: Double, 
  colorB :: Double, 
  colorA :: Double
}

data PaperDetail = PaperDetail { 
  width :: Int, 
  height :: Int, 
  bkgcolor :: RGBA, 
  numLines :: Int, 
  horizMargin :: Double,
  horizLineColor :: RGBA, 
  vertMargin :: Double, 
  vertLineColor :: RGBA,
  vertLinePos :: Double
}

drawBackground :: PaperDetail -> Render ()
drawBackground p = do 
  let w = fromIntegral . width $ p 
      h = fromIntegral . height $ p 
  (setSourceRGBA <$> (colorR.bkgcolor) 
                 <*> (colorG.bkgcolor) 
                 <*> (colorB.bkgcolor) 
                 <*> (colorA.bkgcolor)) p 
                
  rectangle 0 0 w h 
  fill

drawHorizLines :: PaperDetail -> Render () 
drawHorizLines p = do 
  let w = fromIntegral . width $ p 
      h = fromIntegral . height $ p 
      n = fromIntegral . numLines $ p 
      vlist = map (* (h/n)) [0..(n-1)] 
      marginpercent =  horizMargin p 
  let drawOneLine h = do 
        moveTo (w*marginpercent) h  
        lineTo (w*(1-marginpercent)) h
        stroke 
  (setSourceRGBA <$> (colorR.horizLineColor) 
                 <*> (colorG.horizLineColor)
                 <*> (colorB.horizLineColor)
                 <*> (colorA.horizLineColor)) p 
  mapM_ drawOneLine vlist 

drawVertLine :: PaperDetail -> Render () 
drawVertLine p = do 
  let w = fromIntegral . width $ p 
      h = fromIntegral . height $ p 
      n = fromIntegral . numLines $ p 
      marginpercent =  vertMargin p 
      pos = w * vertLinePos p  
  (setSourceRGBA <$> (colorR.vertLineColor) 
                 <*> (colorG.vertLineColor)
                 <*> (colorB.vertLineColor)
                 <*> (colorA.vertLineColor)) p 
  moveTo pos (marginpercent * h)
  lineTo pos ((1-marginpercent)*h)
  stroke 

main = do 
  let paper = PaperDetail 
                { width = 600
                , height = 1024
                , bkgcolor = RGBA 0.9 0.85 0 1.0
                , numLines = 20
                , horizMargin = 0.05
                , horizLineColor = RGBA 0.0 0.0 0.0 1.0
                , vertMargin = 0.01
                , vertLineColor = RGBA 1.0 0.0 0.0 1.0
                , vertLinePos = 0.15 
 
                } 
  
  let pngout fn draw = do 
       sfc <- createImageSurface FormatARGB32 (width paper) (height paper)
       renderWith sfc draw
       surfaceWriteToPNG sfc fn
  
  pngout "notebook.png" $ do 
    drawBackground paper
    drawHorizLines paper
    drawVertLine paper